From 853c5b0f70c4a172cd4de83b1e36684ac09148eb Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 12 Nov 2024 18:55:26 +0100 Subject: [PATCH 01/12] diffusion: added/improved comments --- ouroboros-network/src/Ouroboros/Network/Diffusion.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 84a4519db1..97b3197525 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -770,18 +770,27 @@ runM Interfaces -- withSockets' $ \sockets addresses -> do -- - -- node-to-node server + -- node-to-node server / inbound governor -- withServer sockets connectionManager inboundInfoChannel $ \inboundGovernorThread readInboundState -> do + -- + -- 1. peer state actions + -- debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics withPeerStateActions' connectionManager $ + -- + -- 2. peer selection actions + -- \peerStateActions -> withPeerSelectionActions' (mkInboundPeersMap <$> readInboundState) peerStateActions $ \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> + -- + -- 3. outbound governor + -- Async.withAsync (do labelThisThread "Peer selection governor" From b73e7673172339e64af55916fecbc961a21a9a8f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 31 Dec 2024 16:57:14 +0100 Subject: [PATCH 02/12] ouroboros-network-api: RemoteAddressCBOR newtype wrapper --- .../PeerSelection/PeerSharing/Codec.hs | 90 ++++++++++--------- .../Protocol/PeerSharing/Codec/CDDL.hs | 6 +- 2 files changed, 51 insertions(+), 45 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs index 98d544fa2e..72bbeca74d 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} module Ouroboros.Network.PeerSelection.PeerSharing.Codec ( encodePortNumber , decodePortNumber , encodeRemoteAddress , decodeRemoteAddress + , RemoteAddressEncoding (..) ) where import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR +import Codec.Serialise (Serialise (..)) import Network.Socket (PortNumber, SockAddr (..)) -import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..)) encodePortNumber :: PortNumber -> CBOR.Encoding encodePortNumber = CBOR.encodeWord16 . fromIntegral @@ -27,50 +29,54 @@ decodePortNumber = fromIntegral <$> CBOR.decodeWord16 --- -- /Invariant:/ not a unix socket address type. --- -encodeRemoteAddress :: NodeToNodeVersion -> SockAddr -> CBOR.Encoding -encodeRemoteAddress = - \case - NodeToNodeV_14 -> sockAddr - - where - sockAddr = \case - SockAddrInet pn w -> CBOR.encodeListLen 3 - <> CBOR.encodeWord 0 - <> CBOR.encodeWord32 w - <> encodePortNumber pn - SockAddrInet6 pn _ (w1, w2, w3, w4) _ -> CBOR.encodeListLen 6 - <> CBOR.encodeWord 1 - <> CBOR.encodeWord32 w1 - <> CBOR.encodeWord32 w2 - <> CBOR.encodeWord32 w3 - <> CBOR.encodeWord32 w4 - <> encodePortNumber pn - SockAddrUnix _ -> error "Should never be encoding a SockAddrUnix!" +encodeRemoteAddress :: SockAddr -> CBOR.Encoding +encodeRemoteAddress = \case + SockAddrInet pn w -> CBOR.encodeListLen 3 + <> CBOR.encodeWord 0 + <> CBOR.encodeWord32 w + <> encodePortNumber pn + SockAddrInet6 pn _ (w1, w2, w3, w4) _ -> CBOR.encodeListLen 6 + <> CBOR.encodeWord 1 + <> CBOR.encodeWord32 w1 + <> CBOR.encodeWord32 w2 + <> CBOR.encodeWord32 w3 + <> CBOR.encodeWord32 w4 + <> encodePortNumber pn + SockAddrUnix _ -> error "Should never be encoding a SockAddrUnix!" -- | This decoder should be faithful to the PeerSharing -- CDDL Specification. -- -- See the network design document for more details -- -decodeRemoteAddress :: NodeToNodeVersion -> CBOR.Decoder s SockAddr -decodeRemoteAddress = - \case - NodeToNodeV_14 -> decoder14 +decodeRemoteAddress :: CBOR.Decoder s SockAddr +decodeRemoteAddress = do + _ <- CBOR.decodeListLen + tok <- CBOR.decodeWord + case tok of + 0 -> do + w <- CBOR.decodeWord32 + pn <- decodePortNumber + return (SockAddrInet pn w) + 1 -> do + w1 <- CBOR.decodeWord32 + w2 <- CBOR.decodeWord32 + w3 <- CBOR.decodeWord32 + w4 <- CBOR.decodeWord32 + pn <- decodePortNumber + return (SockAddrInet6 pn 0 (w1, w2, w3, w4) 0) + _ -> fail ("Serialise.decode.SockAddr unexpected tok " ++ show tok) + - where - decoder14 = do - _ <- CBOR.decodeListLen - tok <- CBOR.decodeWord - case tok of - 0 -> do - w <- CBOR.decodeWord32 - pn <- decodePortNumber - return (SockAddrInet pn w) - 1 -> do - w1 <- CBOR.decodeWord32 - w2 <- CBOR.decodeWord32 - w3 <- CBOR.decodeWord32 - w4 <- CBOR.decodeWord32 - pn <- decodePortNumber - return (SockAddrInet6 pn 0 (w1, w2, w3, w4) 0) - _ -> fail ("Serialise.decode.SockAddr unexpected tok " ++ show tok) +-- | A newtype wrapper which provides `Serialise` instance. +-- +newtype RemoteAddressEncoding addr = + RemoteAddressEncoding { getRemoteAddressEncoding :: addr } + deriving (Eq, Ord) + +-- | This instance is used by `LocalStateQuery` mini-protocol codec in +-- `ouroboros-consensus-diffusion`. +-- +instance Serialise (RemoteAddressEncoding SockAddr) where + encode = encodeRemoteAddress . getRemoteAddressEncoding + decode = RemoteAddressEncoding <$> decodeRemoteAddress diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs index 2c8024076d..7892898088 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs @@ -13,7 +13,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Type peerSharingCodec :: NodeToNodeVersion -> Codec (PeerSharing SockAddr) CBOR.DeserialiseFailure IO BL.ByteString -peerSharingCodec ntnVersion = - codecPeerSharing (encodeRemoteAddress ntnVersion) - (decodeRemoteAddress ntnVersion) +peerSharingCodec _ntnVersion = + codecPeerSharing encodeRemoteAddress + decodeRemoteAddress From 98160a81908fe6abb19eb307685a0f4a3e6e9589 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 12 Nov 2024 21:45:02 +0100 Subject: [PATCH 03/12] inbound-governor: expose PublicState's tvar --- .../demo/connection-manager.hs | 7 ++-- .../src/Ouroboros/Network/InboundGovernor.hs | 41 +++++++++---------- .../Network/InboundGovernor/State.hs | 19 +++++++++ .../src/Ouroboros/Network/Server.hs | 27 +++++++----- .../Network/ConnectionManager/Experiments.hs | 3 +- .../src/Ouroboros/Network/Diffusion.hs | 10 +++-- 6 files changed, 67 insertions(+), 40 deletions(-) diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 4ecc64bd47..2287bc1238 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -290,7 +290,8 @@ withBidirectionalConnectionManager snocket makeBearer socket Server.connectionManager = connectionManager, Server.connectionDataFlow = \_ -> Duplex, Server.inboundIdleTimeout = Just protocolIdleTimeout, - Server.inboundInfoChannel = inbgovInfoChannel + Server.inboundInfoChannel = inbgovInfoChannel, + Server.readNetworkState = return () } (\_ _ -> k connectionManager serverAddr) where @@ -298,8 +299,8 @@ withBidirectionalConnectionManager snocket makeBearer socket -> LazySTM.TVar m [[Int]] -> LazySTM.TVar m [[Int]] -> TemperatureBundle - ([MiniProtocolWithExpandedCtx - Mux.InitiatorResponderMode peerAddr ByteString m () ()]) + [MiniProtocolWithExpandedCtx + Mux.InitiatorResponderMode peerAddr ByteString m () ()] serverApplication hotRequestsVar warmRequestsVar establishedRequestsVar diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index 39a4c5932c..f350405bba 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -20,6 +20,8 @@ module Ouroboros.Network.InboundGovernor ( -- * Run Inbound Protocol Governor PublicState (..) + , newPublicStateVar + , emptyPublicState , Arguments (..) , with -- * Trace @@ -88,7 +90,7 @@ inactionTimeout :: DiffTime inactionTimeout = 31.415927 -data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m a b = Arguments { +data Arguments muxMode socket initiatorCtx networkState peerAddr versionNumber versionData m a b = Arguments { transitionTracer :: Tracer m (RemoteTransitionTrace peerAddr), -- ^ transition tracer tracer :: Tracer m (Trace peerAddr), @@ -106,8 +108,9 @@ data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m connectionManager :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr) peerAddr versionData versionNumber - ByteString m a b + ByteString m a b, -- ^ connection manager + readNetworkState :: m networkState } @@ -126,7 +129,7 @@ data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m -- The first one is used in data diffusion for /Node-To-Node protocol/, while the -- other is useful for running a server for the /Node-To-Client protocol/. -- -with :: forall (muxMode :: Mux.Mode) socket initiatorCtx peerAddr versionData versionNumber m a b x. +with :: forall (muxMode :: Mux.Mode) socket initiatorCtx networkState peerAddr versionData versionNumber m a b x. ( Alternative (STM m) , MonadAsync m , MonadCatch m @@ -140,39 +143,33 @@ with :: forall (muxMode :: Mux.Mode) socket initiatorCtx peerAddr versionData ve , Ord peerAddr , HasResponder muxMode ~ True ) - => Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m a b - -> (Async m Void -> m (PublicState peerAddr versionData) -> m x) + => Arguments muxMode socket initiatorCtx networkState peerAddr versionNumber versionData m a b + -> ( Async m Void + -> STM m (PublicState peerAddr versionData) + -> m x) -> m x with Arguments { - transitionTracer = trTracer, - tracer = tracer, - debugTracer = debugTracer, - connectionDataFlow = connectionDataFlow, - infoChannel = infoChannel, - idleTimeout = idleTimeout, - connectionManager = connectionManager + transitionTracer = trTracer, + tracer, + debugTracer, + connectionDataFlow, + infoChannel, + idleTimeout, + connectionManager } k = do labelThisThread "inbound-governor" + -- TODO: avoid a `TVar`. var <- newTVarIO (mkPublicState emptyState) withAsync ((do labelThisThread "inbound-governor-loop" inboundGovernorLoop var emptyState) `catch` handleError var) $ - \thread -> - k thread (readTVarIO var) + \thread -> k thread (readTVar var) where - emptyState :: State muxMode initiatorCtx peerAddr versionData m a b - emptyState = State { - connections = Map.empty, - matureDuplexPeers = Map.empty, - freshDuplexPeers = OrdPSQ.empty, - countersCache = mempty - } - -- Trace final transition mostly for testing purposes. -- -- NOTE: `inboundGovernorLoop` doesn't throw synchronous exceptions, this is diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs index 445ff4f812..d3855f9a48 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs @@ -11,9 +11,12 @@ -- module Ouroboros.Network.InboundGovernor.State ( PublicState (..) + , emptyPublicState + , newPublicStateVar -- * Internals , mkPublicState , State (..) + , emptyState , ConnectionState (..) , Counters (..) , counters @@ -62,6 +65,14 @@ data PublicState peerAddr versionData = PublicState { } +emptyPublicState :: PublicState peerAddr versionData +emptyPublicState = PublicState { + inboundDuplexPeers = Map.empty, + remoteStateMap = Map.empty + } + +newPublicStateVar :: MonadSTM m => m (StrictTVar m (PublicState peerAddr versionData)) +newPublicStateVar = newTVarIO emptyPublicState -- | Smart constructor for `PublicState`. -- @@ -111,6 +122,14 @@ data State muxMode initiatorCtx peerAddr versionData m a b = countersCache :: !(Cache Counters) } +emptyState :: State muxMode initiatorCtx peerAddr versionData m a b +emptyState = State { + connections = Map.empty, + matureDuplexPeers = Map.empty, + freshDuplexPeers = OrdPSQ.empty, + countersCache = mempty + } + -- | Counters for tracing and analysis purposes -- data Counters = Counters { diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs index dd4e4a6630..3b313ca0f7 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs @@ -66,7 +66,7 @@ import Ouroboros.Network.Snocket -- | Server static configuration. -- -data Arguments (muxMode :: Mx.Mode) socket initiatorCtx peerAddr versionData versionNumber bytes m a b = +data Arguments (muxMode :: Mx.Mode) socket initiatorCtx networkState peerAddr versionData versionNumber bytes m a b = Arguments { sockets :: NonEmpty socket, snocket :: Snocket m socket peerAddr, @@ -76,7 +76,7 @@ data Arguments (muxMode :: Mx.Mode) socket initiatorCtx peerAddr versionData ve debugInboundGovernor :: Tracer m (InboundGovernor.Debug peerAddr versionData), connectionLimits :: AcceptedConnectionsLimit, connectionManager :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr) - peerAddr versionData versionNumber bytes m a b, + peerAddr versionData versionNumber bytes m a b, -- | Time for which all protocols need to be idle to trigger -- 'DemotedToCold' transition. @@ -90,7 +90,10 @@ data Arguments (muxMode :: Mx.Mode) socket initiatorCtx peerAddr versionData ve -- inbound connections. -- inboundInfoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData - bytes m a b + bytes m a b, + + -- | read public state + readNetworkState :: m networkState } -- | Server pauses accepting connections after an 'CONNABORTED' error. @@ -113,7 +116,7 @@ server_CONNABORTED_DELAY = 0.5 -- The first one is used in data diffusion for /Node-To-Node protocol/, while the -- other is useful for running a server for the /Node-To-Client protocol/. -- -with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m a b x. +with :: forall muxMode socket initiatorCtx networkState peerAddr versionData versionNumber m a b x. ( Alternative (STM m) , MonadAsync m , MonadDelay m @@ -128,9 +131,11 @@ with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m , Ord peerAddr , Show peerAddr ) - => Arguments muxMode socket initiatorCtx peerAddr versionData versionNumber ByteString m a b + => Arguments muxMode socket initiatorCtx networkState peerAddr versionData versionNumber ByteString m a b -- ^ record which holds all server arguments - -> (Async m Void -> m (InboundGovernor.PublicState peerAddr versionData) -> m x) + -> ( Async m Void + -> STM m (InboundGovernor.PublicState peerAddr versionData) + -> m x) -- ^ a callback which receives a handle to inbound governor thread and can -- read `PublicState`. -- @@ -149,7 +154,8 @@ with Arguments { inboundIdleTimeout, connectionManager, connectionDataFlow, - inboundInfoChannel + inboundInfoChannel, + readNetworkState } k = do let sockets = NonEmpty.toList socks @@ -163,11 +169,12 @@ with Arguments { InboundGovernor.connectionDataFlow = connectionDataFlow, InboundGovernor.infoChannel = inboundInfoChannel, InboundGovernor.idleTimeout = inboundIdleTimeout, - InboundGovernor.connectionManager = connectionManager - } $ \inboundGovernorThread readPublicInboundState -> + InboundGovernor.connectionManager = connectionManager, + InboundGovernor.readNetworkState = readNetworkState + } $ \inboundGovernorThread readInboundGovState -> withAsync (do labelThisThread "Server2 (ouroboros-network-framework)" - k inboundGovernorThread readPublicInboundState) $ \actionThread -> do + k inboundGovernorThread readInboundGovState) $ \actionThread -> do let acceptLoops :: [m Void] acceptLoops = [ (do diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 94e7857e1f..168b624437 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -538,7 +538,8 @@ withBidirectionalConnectionManager name timeouts Server.connectionManager = connectionManager, Server.connectionDataFlow = \(DataFlowProtocolData df _) -> df, Server.inboundIdleTimeout = Just (tProtocolIdleTimeout timeouts), - Server.inboundInfoChannel = inbgovInfoChannel + Server.inboundInfoChannel = inbgovInfoChannel, + Server.readNetworkState = return () } (\inboundGovernorAsync _ -> k connectionManager serverAddr inboundGovernorAsync) `catch` \(e :: SomeException) -> do diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 97b3197525..54ee2c6864 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -388,9 +388,10 @@ runM Interfaces Server.connectionLimits = localConnectionLimits, Server.connectionManager = localConnectionManager, Server.connectionDataFlow = ntcDataFlow, - Server.inboundInfoChannel = localInbInfoChannel + Server.inboundInfoChannel = localInbInfoChannel, + Server.readNetworkState = return () } - (\inboundGovernorThread _ -> Async.wait inboundGovernorThread) + (\thread _ -> Async.wait thread) -- | mkRemoteThread - create remote connection manager @@ -731,7 +732,8 @@ runM Interfaces Server.connectionManager = connectionManager, Server.connectionDataFlow = diNtnDataFlow, Server.inboundIdleTimeout = Just daProtocolIdleTimeout, - Server.inboundInfoChannel = inboundInfoChannel + Server.inboundInfoChannel = inboundInfoChannel, + Server.readNetworkState = return () } -- @@ -785,7 +787,7 @@ runM Interfaces -- \peerStateActions -> withPeerSelectionActions' - (mkInboundPeersMap <$> readInboundState) + (mkInboundPeersMap <$> atomically readInboundState) peerStateActions $ \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> -- From acdb6f2415a1519ec4180ebf51620a3f3b08c0c4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 15 Nov 2024 10:56:53 +0100 Subject: [PATCH 04/12] ouroboros-network-framework: added network state --- .../src/Cardano/Client/Subscription.hs | 4 +- .../demo/connection-manager.hs | 14 ++-- ouroboros-network-framework/demo/ping-pong.hs | 18 ++--- .../io-tests/Test/Ouroboros/Network/Socket.hs | 18 +++-- .../Test/Ouroboros/Network/Server/Sim.hs | 6 +- .../Test/Ouroboros/Network/Socket.hs | 22 +++--- .../Ouroboros/Network/ConnectionHandler.hs | 34 ++++---- .../ConnectionManager/InformationChannel.hs | 4 +- .../src/Ouroboros/Network/InboundGovernor.hs | 39 ++++++---- .../Network/InboundGovernor/Event.hs | 42 +++++----- .../Network/InboundGovernor/State.hs | 54 +++++++------ .../src/Ouroboros/Network/Mux.hs | 78 ++++++++++--------- .../src/Ouroboros/Network/Server.hs | 8 +- .../src/Ouroboros/Network/Socket.hs | 42 +++++----- .../Network/ConnectionManager/Experiments.hs | 18 ++--- ouroboros-network/demo/chain-sync.hs | 27 +++---- .../io-tests/Test/Ouroboros/Network/Pipe.hs | 13 +++- .../io-tests/Test/Ouroboros/Network/Socket.hs | 11 ++- .../src/Ouroboros/Network/Diffusion.hs | 21 ++--- .../src/Ouroboros/Network/Diffusion/Types.hs | 18 +++-- .../src/Ouroboros/Network/NodeToClient.hs | 18 ++--- .../src/Ouroboros/Network/NodeToNode.hs | 23 +++--- .../Network/PeerSelection/Governor/Types.hs | 22 ++++-- .../Network/PeerSelection/PeerStateActions.hs | 68 ++++++++-------- .../Test/Ouroboros/Network/Diffusion/Node.hs | 6 +- .../Network/Diffusion/Node/MiniProtocols.hs | 13 ++-- .../testlib/Test/Ouroboros/Network/Mux.hs | 7 +- 27 files changed, 350 insertions(+), 298 deletions(-) diff --git a/cardano-client/src/Cardano/Client/Subscription.hs b/cardano-client/src/Cardano/Client/Subscription.hs index 049069c6c8..a5db6ebc8c 100644 --- a/cardano-client/src/Cardano/Client/Subscription.hs +++ b/cardano-client/src/Cardano/Client/Subscription.hs @@ -165,7 +165,7 @@ versionedProtocols :: -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx appType LocalAddress bytes m a Void) + (OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a Void) versionedProtocols networkMagic supportedVersions callback = NtC.foldMapVersions applyVersion (Map.toList supportedVersions) where @@ -174,7 +174,7 @@ versionedProtocols networkMagic supportedVersions callback = -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx appType LocalAddress bytes m a Void) + (OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a Void) applyVersion (version, blockVersion) = NtC.versionedNodeToClientProtocols version diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 2287bc1238..77fe3d1d6e 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -202,7 +202,7 @@ withBidirectionalConnectionManager -- ^ series of request possible to do with the bidirectional connection -- manager towards some peer. -> (ConnectionManagerWithExpandedCtx - Mux.InitiatorResponderMode socket peerAddr UnversionedProtocolData + Mux.InitiatorResponderMode socket () peerAddr UnversionedProtocolData UnversionedProtocol ByteString m () () -> peerAddr -> m a) @@ -300,7 +300,7 @@ withBidirectionalConnectionManager snocket makeBearer socket -> LazySTM.TVar m [[Int]] -> TemperatureBundle [MiniProtocolWithExpandedCtx - Mux.InitiatorResponderMode peerAddr ByteString m () ()] + Mux.InitiatorResponderMode () peerAddr ByteString m () ()] serverApplication hotRequestsVar warmRequestsVar establishedRequestsVar @@ -347,7 +347,7 @@ withBidirectionalConnectionManager snocket makeBearer socket :: Mux.MiniProtocolNum -> LazySTM.TVar m [[Int]] -> RunMiniProtocolWithExpandedCtx - Mux.InitiatorResponderMode peerAddr ByteString m () () + Mux.InitiatorResponderMode () peerAddr ByteString m () () reqRespInitiatorAndResponder protocolNum requestsVar = InitiatorAndResponderProtocol (mkMiniProtocolCbFromPeer @@ -399,7 +399,7 @@ runInitiatorProtocols => SingMuxMode muxMode -> Mux.Mux muxMode m -> (forall pt. SingProtocolTemperature pt -> ExpandedInitiatorContext addr m) - -> OuroborosBundleWithExpandedCtx muxMode addr ByteString m a b + -> OuroborosBundleWithExpandedCtx muxMode () addr ByteString m a b -> m (Maybe (TemperatureBundle [a])) runInitiatorProtocols singMuxMode mux getContext @@ -430,7 +430,7 @@ runInitiatorProtocols (WithEstablished established) where runInitiator :: SingProtocolTemperature pt - -> MiniProtocolWithExpandedCtx muxMode addr ByteString m a b + -> MiniProtocolWithExpandedCtx muxMode () addr ByteString m a b -> m (STM m (Either SomeException a)) runInitiator sing ptcl = Mux.runMiniProtocol @@ -548,12 +548,12 @@ bidirectionalExperiment connect :: Int -> ConnectionManagerWithExpandedCtx Mux.InitiatorResponderMode - socket peerAddr UnversionedProtocolData + socket () peerAddr UnversionedProtocolData UnversionedProtocol ByteString IO () () -> IO (Connected peerAddr (HandleWithExpandedCtx - Mux.InitiatorResponderMode peerAddr + Mux.InitiatorResponderMode () peerAddr UnversionedProtocolData ByteString IO () ()) (HandleError Mux.InitiatorResponderMode diff --git a/ouroboros-network-framework/demo/ping-pong.hs b/ouroboros-network-framework/demo/ping-pong.hs index 4ea1834cba..b595faef72 100644 --- a/ouroboros-network-framework/demo/ping-pong.hs +++ b/ouroboros-network-framework/demo/ping-pong.hs @@ -102,8 +102,8 @@ tracer = f `contramapM` stdoutTracer -- Ping pong demo -- -demoProtocol0 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +demoProtocol0 :: RunMiniProtocolWithMinimalCtx appType () addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b demoProtocol0 pingPong = OuroborosApplication [ MiniProtocol { @@ -135,7 +135,7 @@ clientPingPong pipelined = defaultLocalSocketAddr where app :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode LocalAddress LBS.ByteString IO () Void + Mx.InitiatorMode () LocalAddress LBS.ByteString IO () Void app = demoProtocol0 pingPongInitiator pingPongInitiator | pipelined = @@ -175,7 +175,7 @@ serverPingPong = $ \_ serverAsync -> wait serverAsync -- block until server finishes where app :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode LocalAddress LBS.ByteString IO Void () + Mx.ResponderMode () LocalAddress LBS.ByteString IO Void () app = demoProtocol0 pingPongResponder pingPongResponder = @@ -190,9 +190,9 @@ serverPingPong = -- Ping pong demo2 -- -demoProtocol1 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +demoProtocol1 :: RunMiniProtocolWithMinimalCtx appType () addr bytes m a b + -> RunMiniProtocolWithMinimalCtx appType () addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b demoProtocol1 pingPong pingPong' = OuroborosApplication [ MiniProtocol { @@ -229,7 +229,7 @@ clientPingPong2 = defaultLocalSocketAddr where app :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode addr LBS.ByteString IO () Void + Mx.InitiatorMode () addr LBS.ByteString IO () Void app = demoProtocol1 pingpong pingpong' pingpong = @@ -269,7 +269,7 @@ serverPingPong2 = $ \_ serverAsync -> wait serverAsync -- block until async exception where app :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode addr LBS.ByteString IO Void () + Mx.ResponderMode () addr LBS.ByteString IO Void () app = demoProtocol1 pingpong pingpong' pingpong = diff --git a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs index 6a9a8a1259..a95b85c0bc 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -111,8 +111,8 @@ defaultMiniProtocolLimit = 3000000 -- | -- Allow to run a singly req-resp protocol. -- -testProtocols2 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +testProtocols2 :: RunMiniProtocolWithMinimalCtx appType () addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b testProtocols2 reqResp = OuroborosApplication [ MiniProtocol { @@ -207,7 +207,7 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = let -- Server Node; only req-resp server responderApp :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO Void () + Mx.ResponderMode () Socket.SockAddr BL.ByteString IO Void () responderApp = testProtocols2 reqRespResponder reqRespResponder = @@ -223,7 +223,7 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = -- Client Node; only req-resp client initiatorApp :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO () Void + Mx.InitiatorMode () Socket.SockAddr BL.ByteString IO () Void initiatorApp = testProtocols2 reqRespInitiator reqRespInitiator = @@ -299,7 +299,7 @@ prop_socket_recv_error f rerr = sv <- newEmptyTMVarIO let app :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO Void () + Mx.ResponderMode () Socket.SockAddr BL.ByteString IO Void () app = testProtocols2 reqRespResponder reqRespResponder = @@ -363,8 +363,10 @@ prop_socket_recv_error f rerr = <- getOuroborosApplication app , (miniProtocolDir, action) <- case miniProtocolRun of - ResponderProtocolOnly initiator -> - [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb initiator respCtx)] + ResponderProtocolOnly responder -> + [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] + ResponderProtocolOnlyWithState {} -> + error "ResponderProtocolOnlyWithState: not-supported" ] withAsync (Mx.run nullTracer mux bearer) $ \aid -> do @@ -498,7 +500,7 @@ prop_socket_client_connect_error _ xs = cv <- newEmptyTMVarIO let app :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO () Void + Mx.InitiatorMode () Socket.SockAddr BL.ByteString IO () Void app = testProtocols2 reqRespInitiator reqRespInitiator = diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index 401b218bab..cb000b68f2 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -851,15 +851,15 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer -> peerAddr -> StrictTQueue m (ConnectionHandlerMessage peerAddr req) -- ^ control channel - -> ConnectionManagerWithExpandedCtx muxMode socket peerAddr DataFlowProtocolData UnversionedProtocol ByteString m [resp] a - -> Map.Map peerAddr (HandleWithExpandedCtx muxMode peerAddr DataFlowProtocolData ByteString m [resp] a) + -> ConnectionManagerWithExpandedCtx muxMode socket () peerAddr DataFlowProtocolData UnversionedProtocol ByteString m [resp] a + -> Map.Map peerAddr (HandleWithExpandedCtx muxMode () peerAddr DataFlowProtocolData ByteString m [resp] a) -- ^ active connections -> StrictTVar m (Map.Map (ConnectionId peerAddr) (TemperatureBundle (StrictTQueue m [req]))) -- ^ mini protocol queues -> m () connectionLoop muxMode localAddr cc cm connMap0 connVar = go connMap0 where - go :: Map.Map peerAddr (HandleWithExpandedCtx muxMode peerAddr DataFlowProtocolData ByteString m [resp] a) -- active connections + go :: Map.Map peerAddr (HandleWithExpandedCtx muxMode () peerAddr DataFlowProtocolData ByteString m [resp] a) -- active connections -> m () go !connMap = atomically (readTQueue cc) >>= \ case NewConnection remoteAddr -> do diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs index b5dac507f7..c9fd32fa2d 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs @@ -114,8 +114,8 @@ defaultMiniProtocolLimit = 3000000 -- | -- Allow to run a singly req-resp protocol. -- -testProtocols2 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +testProtocols2 :: RunMiniProtocolWithMinimalCtx appType () addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b testProtocols2 reqResp = OuroborosApplication [ MiniProtocol { @@ -178,7 +178,7 @@ prop_socket_send_recv_unix request response = ioProperty $ do mempty request response cleanUp serverName cleanUp clientName - return $ r + return r where cleanUp name = do catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) @@ -210,7 +210,7 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = let -- Server Node; only req-resp server responderApp :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO Void () + Mx.ResponderMode () Socket.SockAddr BL.ByteString IO Void () responderApp = testProtocols2 reqRespResponder reqRespResponder = @@ -226,7 +226,7 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = -- Client Node; only req-resp client initiatorApp :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO () Void + Mx.InitiatorMode () Socket.SockAddr BL.ByteString IO () Void initiatorApp = testProtocols2 reqRespInitiator reqRespInitiator = @@ -304,7 +304,7 @@ prop_socket_recv_error f rerr = sv <- newEmptyTMVarIO let app :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO Void () + Mx.ResponderMode () Socket.SockAddr BL.ByteString IO Void () app = testProtocols2 reqRespResponder reqRespResponder = @@ -368,8 +368,10 @@ prop_socket_recv_error f rerr = <- getOuroborosApplication app , (miniProtocolDir, action) <- case miniProtocolRun of - ResponderProtocolOnly initiator -> - [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb initiator respCtx)] + ResponderProtocolOnly responder -> + [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] + ResponderProtocolOnlyWithState _ -> + error "prop_socket_recv_error: ResponderProtocolOnlyWithState - not supported" ] withAsync (Mx.run nullTracer mux bearer) $ \aid -> do @@ -503,7 +505,7 @@ prop_socket_client_connect_error _ xs = cv <- newEmptyTMVarIO let app :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO () Void + Mx.InitiatorMode () Socket.SockAddr BL.ByteString IO () Void app = testProtocols2 reqRespInitiator reqRespInitiator = @@ -529,7 +531,7 @@ prop_socket_client_connect_error _ xs = ctaConnectTracers = NetworkConnectTracers activeMuxTracer nullTracer, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } - (flip configureSocket Nothing) + (`configureSocket` Nothing) (unversionedProtocol app) (Just $ Socket.addrAddress clientAddr) (Socket.addrAddress serverAddr) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index d2720afb16..c87f4cd3d0 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -107,10 +107,10 @@ sduHandshakeTimeout = 10 -- * 'HandleError' -- - the multiplexer thrown 'MuxError'. -- -data Handle (muxMode :: Mx.Mode) initiatorCtx responderCtx versionData bytes m a b = +data Handle (muxMode :: Mx.Mode) initiatorCtx responderCtx networkState versionData bytes m a b = Handle { hMux :: !(Mux muxMode m), - hMuxBundle :: !(OuroborosBundle muxMode initiatorCtx responderCtx bytes m a b), + hMuxBundle :: !(OuroborosBundle muxMode initiatorCtx responderCtx networkState bytes m a b), hControlMessage :: !(TemperatureBundle (StrictTVar m ControlMessage)), hVersionData :: !versionData } @@ -118,20 +118,20 @@ data Handle (muxMode :: Mx.Mode) initiatorCtx responderCtx versionData bytes m a -- | 'Handle' used by `node-to-node` P2P connections. -- -type HandleWithExpandedCtx muxMode peerAddr versionData bytes m a b = +type HandleWithExpandedCtx muxMode networkState peerAddr versionData bytes m a b = Handle muxMode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - versionData bytes m a b + networkState versionData bytes m a b -- | 'Handle' used by: -- -- * `node-to-node` non P2P mode; -- * `node-to-client` connections. -- -type HandleWithMinimalCtx muxMode peerAddr versionData bytes m a b = +type HandleWithMinimalCtx muxMode networkState peerAddr versionData bytes m a b = Handle muxMode (MinimalInitiatorContext peerAddr) (ResponderContext peerAddr) - versionData bytes m a b + networkState versionData bytes m a b data HandleError (muxMode :: Mx.Mode) versionNumber where HandleHandshakeClientError @@ -174,12 +174,12 @@ classifyHandleError (HandleError _) = -- | Type of 'ConnectionHandler' implemented in this module. -- -type MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData bytes m a b = +type MuxConnectionHandler muxMode socket initiatorCtx responderCtx networkState peerAddr versionNumber versionData bytes m a b = ConnectionHandler muxMode (ConnectionHandlerTrace versionNumber versionData) socket peerAddr - (Handle muxMode initiatorCtx responderCtx versionData bytes m a b) + (Handle muxMode initiatorCtx responderCtx networkState versionData bytes m a b) (HandleError muxMode versionNumber) versionNumber versionData @@ -187,17 +187,17 @@ type MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr vers -- | Type alias for 'ConnectionManager' using 'Handle'. -- -type MuxConnectionManager muxMode socket initiatorCtx responderCtx peerAddr versionData versionNumber bytes m a b = +type MuxConnectionManager muxMode socket initiatorCtx responderCtx networkState peerAddr versionData versionNumber bytes m a b = ConnectionManager muxMode socket peerAddr - (Handle muxMode initiatorCtx responderCtx versionData bytes m a b) + (Handle muxMode initiatorCtx responderCtx networkState versionData bytes m a b) (HandleError muxMode versionNumber) m -- | Type alias for 'ConnectionManager' which is using expanded context. -- -type ConnectionManagerWithExpandedCtx muxMode socket peerAddr versionData versionNumber bytes m a b = +type ConnectionManagerWithExpandedCtx muxMode socket networkState peerAddr versionData versionNumber bytes m a b = ConnectionManager muxMode socket peerAddr - (HandleWithExpandedCtx muxMode peerAddr versionData bytes m a b) + (HandleWithExpandedCtx muxMode networkState peerAddr versionData bytes m a b) (HandleError muxMode versionNumber) m @@ -209,7 +209,7 @@ type ConnectionManagerWithExpandedCtx muxMode socket peerAddr versionData versio -- independent. -- makeConnectionHandler - :: forall initiatorCtx responderCtx peerAddr muxMode socket versionNumber versionData m a b. + :: forall initiatorCtx responderCtx networkState peerAddr muxMode socket versionNumber versionData m a b. ( Alternative (STM m) , MonadAsync m , MonadDelay m @@ -229,11 +229,11 @@ makeConnectionHandler -- evidence that we can use mux with it. -> HandshakeArguments (ConnectionId peerAddr) versionNumber versionData m -> Versions versionNumber versionData - (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m a b) + (OuroborosBundle muxMode initiatorCtx responderCtx networkState ByteString m a b) -> (ThreadId m, RethrowPolicy) -- ^ 'ThreadId' and rethrow policy. Rethrow policy might throw an async -- exception to that thread, when trying to terminate the process. - -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b + -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx networkState peerAddr versionNumber versionData ByteString m a b makeConnectionHandler muxTracer singMuxMode forkPolicy handshakeArguments @@ -279,7 +279,7 @@ makeConnectionHandler muxTracer singMuxMode => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) socket peerAddr - (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) + (Handle muxMode initiatorCtx responderCtx networkState versionData ByteString m a b) (HandleError muxMode versionNumber) versionNumber versionData @@ -348,7 +348,7 @@ makeConnectionHandler muxTracer singMuxMode => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) socket peerAddr - (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) + (Handle muxMode initiatorCtx responderCtx networkState versionData ByteString m a b) (HandleError muxMode versionNumber) versionNumber versionData diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs index a133382ec4..819f8dad2b 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs @@ -35,8 +35,8 @@ data InformationChannel a m = -- * /Producer:/ connection manger for duplex outbound connections. -- * /Consumer:/ inbound governor. -- -type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData bytes m a b = - InformationChannel (NewConnectionInfo peerAddr (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData bytes m a b)) m +type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx networkState peerAddr versionData bytes m a b = + InformationChannel (NewConnectionInfo peerAddr (Handle muxMode initiatorCtx (ResponderContext peerAddr) networkState versionData bytes m a b)) m -- | Create a new 'InformationChannel' backed by a `TBQueue`. diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index f350405bba..bb548c0db7 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -99,14 +99,16 @@ data Arguments muxMode socket initiatorCtx networkState peerAddr versionNumber v -- ^ debug inbound governor tracer connectionDataFlow :: versionData -> DataFlow, -- ^ connection data flow - infoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData ByteString m a b, + infoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx networkState peerAddr versionData ByteString m a b, -- ^ 'InformationChannel' which passes 'NewConnectionInfo' for outbound -- connections from connection manager to the inbound governor. idleTimeout :: Maybe DiffTime, -- ^ protocol idle timeout. The remote site must restart a mini-protocol -- within given timeframe (Nothing indicates no timeout). connectionManager :: MuxConnectionManager muxMode socket initiatorCtx - (ResponderContext peerAddr) peerAddr + (ResponderContext peerAddr) + networkState + peerAddr versionData versionNumber ByteString m a b, -- ^ connection manager @@ -156,7 +158,8 @@ with connectionDataFlow, infoChannel, idleTimeout, - connectionManager + connectionManager, + readNetworkState } k = do @@ -195,7 +198,7 @@ with -- inboundGovernorLoop :: StrictTVar m (PublicState peerAddr versionData) - -> State muxMode initiatorCtx peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b -> m Void inboundGovernorLoop var !state = do time <- getMonotonicTime @@ -219,7 +222,7 @@ with <> firstPeerPromotedToHot <> firstPeerDemotedToWarm - :: EventSignal muxMode initiatorCtx peerAddr versionData m a b + :: EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b ) (connections state) <> FirstToFinish ( @@ -278,7 +281,7 @@ with <- foldM (\acc mpd@MiniProtocolData { mpdMiniProtocol } -> - runResponder csMux mpd >>= \case + runResponder csMux readNetworkState mpd >>= \case -- synchronous exceptions when starting -- a mini-protocol are non-recoverable; we -- close the connection and allow the server @@ -379,7 +382,7 @@ with return (Just tConnId, state') Right _ -> - runResponder tMux mpd >>= \case + runResponder tMux readNetworkState mpd >>= \case Right completionAction -> do traceWith tracer (TrResponderRestarted tConnId num) let state' = updateMiniProtocol tConnId num completionAction state @@ -569,7 +572,7 @@ with -- @'HasResponder' mode ~ True@ is used to rule out -- 'InitiatorProtocolOnly' case. -- -runResponder :: forall (mode :: Mux.Mode) initiatorCtx peerAddr m a b. +runResponder :: forall (mode :: Mux.Mode) initiatorCtx networkState peerAddr m a b. ( Alternative (STM m) , HasResponder mode ~ True , MonadAsync m @@ -579,9 +582,10 @@ runResponder :: forall (mode :: Mux.Mode) initiatorCtx peerAddr m a b. , MonadThrow (STM m) ) => Mux.Mux mode m - -> MiniProtocolData mode initiatorCtx peerAddr m a b + -> m networkState + -> MiniProtocolData mode initiatorCtx networkState peerAddr m a b -> m (Either SomeException (STM m (Either SomeException b))) -runResponder mux +runResponder mux readNetworkState MiniProtocolData { mpdMiniProtocol = miniProtocol, mpdResponderContext = responderContext @@ -598,6 +602,13 @@ runResponder mux (miniProtocolStart miniProtocol) (runMiniProtocolCb responder responderContext) + ResponderProtocolOnlyWithState responder -> + Mux.runMiniProtocol + mux (miniProtocolNum miniProtocol) + Mux.ResponderDirectionOnly + (miniProtocolStart miniProtocol) + (runMiniProtocolCb responder (readNetworkState, responderContext)) + InitiatorAndResponderProtocol _ responder -> Mux.runMiniProtocol mux (miniProtocolNum miniProtocol) @@ -628,8 +639,8 @@ type RemoteTransitionTrace peerAddr = TransitionTrace' peerAddr (Maybe RemoteSt) mkRemoteTransitionTrace :: Ord peerAddr => ConnectionId peerAddr - -> State muxMode initiatorCtx peerAddr versionData m a b - -> State muxMode initiatorCtx peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b -> RemoteTransitionTrace peerAddr mkRemoteTransitionTrace connId fromState toState = TransitionTrace @@ -673,5 +684,5 @@ data Trace peerAddr deriving Show -data Debug peerAddr versionData = forall muxMode initiatorCtx m a b. - Debug (State muxMode initiatorCtx peerAddr versionData m a b) +data Debug peerAddr versionData = forall muxMode initiatorCtx networkState m a b. + Debug (State muxMode initiatorCtx networkState peerAddr versionData m a b) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs index 271325ed15..b7b01e47a5 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs @@ -74,12 +74,12 @@ instance Show peerAddr -- | Edge triggered events to which the /inbound protocol governor/ reacts. -- -data Event (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b +data Event (muxMode :: Mux.Mode) initiatorCtx networkState peerAddr versionData m a b -- | A request to start mini-protocol bundle, either from the server or from -- connection manager after a duplex connection was negotiated. -- = NewConnection !(NewConnectionInfo peerAddr - (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData ByteString m a b)) + (Handle muxMode initiatorCtx (ResponderContext peerAddr) networkState versionData ByteString m a b)) -- | A multiplexer exited. -- @@ -87,7 +87,7 @@ data Event (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b -- | A mini-protocol terminated either cleanly or abruptly. -- - | MiniProtocolTerminated !(Terminated muxMode initiatorCtx peerAddr m a b) + | MiniProtocolTerminated !(Terminated muxMode initiatorCtx networkState peerAddr m a b) -- | Transition from 'RemoteEstablished' to 'RemoteIdle'. -- @@ -127,15 +127,15 @@ data Event (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b -- | A signal which returns an 'Event'. Signals are combined together and -- passed used to fold the current state map. -- -type EventSignal (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b = +type EventSignal (muxMode :: Mux.Mode) initiatorCtx networkState peerAddr versionData m a b = ConnectionId peerAddr - -> ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> FirstToFinish (STM m) (Event muxMode initiatorCtx peerAddr versionData m a b) + -> ConnectionState muxMode initiatorCtx networkState peerAddr versionData m a b + -> FirstToFinish (STM m) (Event muxMode initiatorCtx networkState peerAddr versionData m a b) -- | A mux stopped. If mux exited cleanly no error is attached. -- firstMuxToFinish :: MonadSTM m - => EventSignal muxMode initiatorCtx peerAddr versionData m a b + => EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstMuxToFinish connId ConnectionState { csMux } = FirstToFinish $ MuxFinished connId <$> Mux.stopped csMux @@ -144,10 +144,10 @@ firstMuxToFinish connId ConnectionState { csMux } = -- and pass it to the main loop. This is just enough to decide if we need to -- restart a mini-protocol and to do the restart. -- -data Terminated muxMode initiatorCtx peerAddr m a b = Terminated { +data Terminated muxMode initiatorCtx networkState peerAddr m a b = Terminated { tConnId :: !(ConnectionId peerAddr), tMux :: !(Mux.Mux muxMode m), - tMiniProtocolData :: !(MiniProtocolData muxMode initiatorCtx peerAddr m a b), + tMiniProtocolData :: !(MiniProtocolData muxMode initiatorCtx networkState peerAddr m a b), tDataFlow :: !DataFlow, tResult :: !(Either SomeException b) } @@ -159,7 +159,7 @@ data Terminated muxMode initiatorCtx peerAddr m a b = Terminated { -- firstMiniProtocolToFinish :: Alternative (STM m) => (versionData -> DataFlow) - -> EventSignal muxMode initiatorCtx peerAddr versionData m a b + -> EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstMiniProtocolToFinish connDataFlow connId @@ -193,11 +193,11 @@ firstMiniProtocolToFinish -- transition, but here we don't make a distinction on @Duplex@ and -- @Unidirectional@ connections. -- -firstPeerPromotedToWarm :: forall muxMode initiatorCtx peerAddr versionData m a b. +firstPeerPromotedToWarm :: forall muxMode initiatorCtx networkState peerAddr versionData m a b. ( Alternative (STM m) , MonadSTM m ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b + => EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstPeerPromotedToWarm connId ConnectionState { csMux, csRemoteState } @@ -230,7 +230,7 @@ firstPeerPromotedToWarm where fn :: (MiniProtocolNum, MiniProtocolDir) -> STM m MiniProtocolStatus - -> FirstToFinish (STM m) (Event muxMode initiatorCtx peerAddr versionData m a b) + -> FirstToFinish (STM m) (Event muxMode initiatorCtx networkState peerAddr versionData m a b) fn = \(_miniProtocolNum, miniProtocolDir) miniProtocolStatus -> case miniProtocolDir of InitiatorDir -> mempty @@ -247,11 +247,11 @@ firstPeerPromotedToWarm -- | Detect when a first warm peer is promoted to hot (any hot mini-protocols -- is running). -- -firstPeerPromotedToHot :: forall muxMode initiatorCtx peerAddr versionData m a b. +firstPeerPromotedToHot :: forall muxMode initiatorCtx networkState peerAddr versionData m a b. ( Alternative (STM m) , MonadSTM m ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b + => EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstPeerPromotedToHot connId connState@ConnectionState { csRemoteState } = case csRemoteState of @@ -267,7 +267,7 @@ firstPeerPromotedToHot RemoteIdle {} -> mempty where -- only hot mini-protocols; - hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b + hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx networkState peerAddr versionData m a b -> Map (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus) hotMiniProtocolStateMap ConnectionState { csMux, csMiniProtocolMap } = @@ -298,11 +298,11 @@ firstPeerPromotedToHot -- | Detect when all hot mini-protocols terminates, which triggers the -- `RemoteHot → RemoteWarm` transition. -- -firstPeerDemotedToWarm :: forall muxMode initiatorCtx peerAddr versionData m a b. +firstPeerDemotedToWarm :: forall muxMode initiatorCtx networkState peerAddr versionData m a b. ( Alternative (STM m) , MonadSTM m ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b + => EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstPeerDemotedToWarm connId connState@ConnectionState { csRemoteState } = case csRemoteState of @@ -313,7 +313,7 @@ firstPeerDemotedToWarm _ -> mempty where -- only hot mini-protocols; - hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b + hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx networkState peerAddr versionData m a b -> Map (MiniProtocolNum, MiniProtocolDir) (STM m MiniProtocolStatus) hotMiniProtocolStateMap ConnectionState { csMux, csMiniProtocolMap } = @@ -349,7 +349,7 @@ firstPeerDemotedToWarm firstPeerDemotedToCold :: ( Alternative (STM m) , MonadSTM m ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b + => EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstPeerDemotedToCold connId ConnectionState { @@ -391,7 +391,7 @@ firstPeerDemotedToCold -- | First peer for which the 'RemoteIdle' timeout expires. -- firstPeerCommitRemote :: Alternative (STM m) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b + => EventSignal muxMode initiatorCtx networkState peerAddr versionData m a b firstPeerCommitRemote connId ConnectionState { csRemoteState } = case csRemoteState of diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs index d3855f9a48..b71d34821f 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs @@ -46,6 +46,14 @@ import Network.Mux qualified as Mux import Ouroboros.Network.Context import Ouroboros.Network.Mux +-- | Remote connection state tracked by inbound protocol governor. +-- +data RemoteSt = RemoteWarmSt + | RemoteHotSt + | RemoteIdleSt + | RemoteColdSt + deriving (Eq, Show) + -- | Public inbound governor state. -- @@ -82,8 +90,8 @@ newPublicStateVar = newTVarIO emptyPublicState -- `Map.mapKeysMonotonic`. -- mkPublicState - :: forall muxMode initatorCtx versionData peerAddr m a b. - State muxMode initatorCtx peerAddr versionData m a b + :: forall muxMode initatorCtx networkState versionData peerAddr m a b. + State muxMode initatorCtx networkState peerAddr versionData m a b -> PublicState peerAddr versionData mkPublicState State { connections, matureDuplexPeers } @@ -97,13 +105,13 @@ mkPublicState -- can be observable from outside. Future version could -- contain additional statistics on the peers. -- -data State muxMode initiatorCtx peerAddr versionData m a b = +data State muxMode initiatorCtx networkState peerAddr versionData m a b = State { -- | Map of connections state. Modifying 'igsConnections' outside of -- 'inboundGovernorLoop' is not safe. -- connections :: !(Map (ConnectionId peerAddr) - (ConnectionState muxMode initiatorCtx peerAddr versionData m a b)), + (ConnectionState muxMode initiatorCtx networkState peerAddr versionData m a b)), -- | Map of mature duplex peers. -- @@ -122,7 +130,7 @@ data State muxMode initiatorCtx peerAddr versionData m a b = countersCache :: !(Cache Counters) } -emptyState :: State muxMode initiatorCtx peerAddr versionData m a b +emptyState :: State muxMode initiatorCtx networkState peerAddr versionData m a b emptyState = State { connections = Map.empty, matureDuplexPeers = Map.empty, @@ -154,7 +162,7 @@ instance Monoid Counters where mempty = Counters 0 0 0 0 -counters :: State muxMode initiatorCtx peerAddr versionData m a b +counters :: State muxMode initiatorCtx networkState peerAddr versionData m a b -> Counters counters State { connections } = foldMap (\ConnectionState { csRemoteState } -> @@ -167,10 +175,10 @@ counters State { connections } = connections -data MiniProtocolData muxMode initiatorCtx peerAddr m a b = MiniProtocolData { +data MiniProtocolData muxMode initiatorCtx networkState peerAddr m a b = MiniProtocolData { -- | Static 'MiniProtocol' description. -- - mpdMiniProtocol :: !(MiniProtocol muxMode initiatorCtx (ResponderContext peerAddr) ByteString m a b), + mpdMiniProtocol :: !(MiniProtocol muxMode initiatorCtx (ResponderContext peerAddr) networkState ByteString m a b), mpdResponderContext :: !(ResponderContext peerAddr), @@ -182,7 +190,7 @@ data MiniProtocolData muxMode initiatorCtx peerAddr m a b = MiniProtocolData { -- | Per connection state tracked by /inbound protocol governor/. -- -data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = ConnectionState { +data ConnectionState muxMode initiatorCtx networkState peerAddr versionData m a b = ConnectionState { -- | Mux interface. -- csMux :: !(Mux.Mux muxMode m), @@ -195,7 +203,7 @@ data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = Connectio -- 'ProtocolTemperature' -- csMiniProtocolMap :: !(Map MiniProtocolNum - (MiniProtocolData muxMode initiatorCtx peerAddr m a b)), + (MiniProtocolData muxMode initiatorCtx networkState peerAddr m a b)), -- | Map of all running mini-protocol completion STM actions. -- @@ -218,8 +226,8 @@ data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = Connectio -- unregisterConnection :: Ord peerAddr => ConnectionId peerAddr - -> State muxMode initiatorCtx peerAddr versionData m a b - -> State muxMode initiatorCtx peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b unregisterConnection connId state = state { connections = assert (connId `Map.member` connections state) $ @@ -240,8 +248,8 @@ updateMiniProtocol :: Ord peerAddr => ConnectionId peerAddr -> MiniProtocolNum -> STM m (Either SomeException b) - -> State muxMode initiatorCtx peerAddr versionData m a b - -> State muxMode initiatorCtx peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b updateMiniProtocol connId miniProtocolNum completionAction state = state { connections = Map.adjust (\connState@ConnectionState { csCompletionMap } -> @@ -314,8 +322,8 @@ pattern RemoteEstablished <- (remoteEstablished -> Just _) updateRemoteState :: Ord peerAddr => ConnectionId peerAddr -> RemoteState m - -> State muxMode initiatorCtx peerAddr versionData m a b - -> State muxMode initiatorCtx peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b updateRemoteState connId csRemoteState state = state { connections = @@ -328,8 +336,8 @@ updateRemoteState connId csRemoteState state = mapRemoteState :: Ord peerAddr => ConnectionId peerAddr -> (RemoteState m -> RemoteState m) - -> State muxMode initiatorCtx peerAddr versionData m a b - -> State muxMode initiatorCtx peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b + -> State muxMode initiatorCtx networkState peerAddr versionData m a b mapRemoteState connId fn state = state { connections = @@ -341,16 +349,6 @@ mapRemoteState connId fn state = } --- | Remote connection state tracked by inbound protocol governor. --- --- This type is used for tracing. --- -data RemoteSt = RemoteWarmSt - | RemoteHotSt - | RemoteIdleSt - | RemoteColdSt - deriving (Eq, Show) - mkRemoteSt :: RemoteState m -> RemoteSt mkRemoteSt RemoteWarm = RemoteWarmSt diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs b/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs index ceec14bddf..1c5684a178 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Mux.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -213,22 +212,22 @@ instance Applicative TemperatureBundle where -- Useful type synonyms -- -type OuroborosBundle (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b = - TemperatureBundle [MiniProtocol mode initiatorCtx responderCtx bytes m a b] +type OuroborosBundle (mode :: Mux.Mode) initiatorCtx responderCtx networkState bytes m a b = + TemperatureBundle [MiniProtocol mode initiatorCtx responderCtx networkState bytes m a b] -- | 'OuroborosBundle' used in P2P. -- -type OuroborosBundleWithExpandedCtx (mode :: Mux.Mode) peerAddr bytes m a b = +type OuroborosBundleWithExpandedCtx (mode :: Mux.Mode) networkState peerAddr bytes m a b = OuroborosBundle mode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -type OuroborosBundleWithMinimalCtx (mode :: Mux.Mode) peerAddr bytes m a b = +type OuroborosBundleWithMinimalCtx (mode :: Mux.Mode) networkState peerAddr bytes m a b = OuroborosBundle mode (MinimalInitiatorContext peerAddr) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -- | Each mini-protocol is represented by its @@ -237,7 +236,7 @@ type OuroborosBundleWithMinimalCtx (mode :: Mux.Mode) peerAddr bytes m a b = -- * ingress size limit, and -- * callbacks. -- -data MiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b = +data MiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx networkState bytes m a b = MiniProtocol { miniProtocolNum :: !MiniProtocolNum, -- ^ mini-protocol number @@ -246,12 +245,12 @@ data MiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b = -- started using `StartEagerly`. miniProtocolLimits :: !MiniProtocolLimits, -- ^ mini-protocol limits - miniProtocolRun :: !(RunMiniProtocol mode initiatorCtx responderCtx bytes m a b) + miniProtocolRun :: !(RunMiniProtocol mode initiatorCtx responderCtx networkState bytes m a b) -- ^ mini-protocol callback(s) } mkMiniProtocolInfo :: ForkPolicyCb - -> MiniProtocol mode initiatorCtx responderCtx bytes m a b + -> MiniProtocol mode initiatorCtx responderCtx networkState bytes m a b -> [MiniProtocolInfo mode] mkMiniProtocolInfo forkPolicy MiniProtocol { miniProtocolNum, @@ -268,66 +267,71 @@ mkMiniProtocolInfo forkPolicy MiniProtocol { (Mux.protocolDirEnum dir) } | dir <- case miniProtocolRun of - InitiatorProtocolOnly{} -> [ Mux.InitiatorDirectionOnly ] - ResponderProtocolOnly{} -> [ Mux.ResponderDirectionOnly ] - InitiatorAndResponderProtocol{} -> [ Mux.InitiatorDirection - , Mux.ResponderDirection ] + InitiatorProtocolOnly{} -> [ Mux.InitiatorDirectionOnly ] + ResponderProtocolOnly{} -> [ Mux.ResponderDirectionOnly ] + ResponderProtocolOnlyWithState{} -> [ Mux.ResponderDirectionOnly ] + InitiatorAndResponderProtocol{} -> [ Mux.InitiatorDirection + , Mux.ResponderDirection ] ] -- | 'MiniProtocol' type used in P2P. -- -type MiniProtocolWithExpandedCtx mode peerAddr bytes m a b = +type MiniProtocolWithExpandedCtx mode networkState peerAddr bytes m a b = MiniProtocol mode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -- | 'MiniProtocol' type used in non-P2P. -- -type MiniProtocolWithMinimalCtx mode peerAddr bytes m a b = +type MiniProtocolWithMinimalCtx mode networkState peerAddr bytes m a b = MiniProtocol mode (MinimalInitiatorContext peerAddr) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -- | 'RunMiniProtocol'. It also capture context (the `IsBigLedgerPeer`) which -- is passed to the mini-protocol when a mini-protocol is started. -- -data RunMiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b where +data RunMiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx networkState bytes m a b where InitiatorProtocolOnly :: (MiniProtocolCb initiatorCtx bytes m a) - -> RunMiniProtocol Mux.InitiatorMode initiatorCtx responderCtx bytes m a Void + -> RunMiniProtocol Mux.InitiatorMode initiatorCtx responderCtx networkState bytes m a Void ResponderProtocolOnly :: (MiniProtocolCb responderCtx bytes m b) - -> RunMiniProtocol Mux.ResponderMode initiatorCtx responderCtx bytes m Void b + -> RunMiniProtocol Mux.ResponderMode initiatorCtx responderCtx networkState bytes m Void b + + ResponderProtocolOnlyWithState + :: (MiniProtocolCb (m networkState, responderCtx) bytes m b) + -> RunMiniProtocol Mux.ResponderMode initiatorCtx responderCtx networkState bytes m Void b InitiatorAndResponderProtocol :: (MiniProtocolCb initiatorCtx bytes m a) -> (MiniProtocolCb responderCtx bytes m b) - -> RunMiniProtocol Mux.InitiatorResponderMode initiatorCtx responderCtx bytes m a b + -> RunMiniProtocol Mux.InitiatorResponderMode initiatorCtx responderCtx networkState bytes m a b -- | 'RunMiniProtocol' with 'ExpandedInitiatorContext' and 'ResponderContext'. -- -- Used to run P2P node-to-node applications. -- -type RunMiniProtocolWithExpandedCtx mode peerAddr bytes m a b = +type RunMiniProtocolWithExpandedCtx mode networkState peerAddr bytes m a b = RunMiniProtocol mode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -- | 'RunMiniProtocol' with 'MinimalInitiatorContext' and 'ResponderContext'. -- -- Use to run node-to-client application as well as in some non p2p contexts. -- -type RunMiniProtocolWithMinimalCtx mode peerAddr bytes m a b = +type RunMiniProtocolWithMinimalCtx mode networkState peerAddr bytes m a b = RunMiniProtocol mode (MinimalInitiatorContext peerAddr) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -- @@ -421,22 +425,22 @@ contramapMiniProtocolCbCtx f (MiniProtocolCb cb) = MiniProtocolCb (cb . f) -- @Channel -> m a@ action. -- -- Note: Only used in some non-P2P contexts. -newtype OuroborosApplication (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b = +newtype OuroborosApplication (mode :: Mux.Mode) initiatorCtx responderCtx networkState bytes m a b = OuroborosApplication { getOuroborosApplication - :: [MiniProtocol mode initiatorCtx responderCtx bytes m a b] + :: [MiniProtocol mode initiatorCtx responderCtx networkState bytes m a b] } -- | 'OuroborosApplication' used in NonP2P mode. -- -type OuroborosApplicationWithMinimalCtx mode peerAddr bytes m a b = +type OuroborosApplicationWithMinimalCtx mode networkState peerAddr bytes m a b = OuroborosApplication mode (MinimalInitiatorContext peerAddr) (ResponderContext peerAddr) - bytes m a b + networkState bytes m a b -fromOuroborosBundle :: OuroborosBundle mode initiatorCtx responderCtx bytes m a b - -> OuroborosApplication mode initiatorCtx responderCtx bytes m a b +fromOuroborosBundle :: OuroborosBundle mode initiatorCtx responderCtx networkState bytes m a b + -> OuroborosApplication mode initiatorCtx responderCtx networkState bytes m a b fromOuroborosBundle = OuroborosApplication . fold @@ -478,15 +482,15 @@ responderForkPolicy salt numCapabilities = ForkPolicy { toMiniProtocolInfos :: ForkPolicyCb - -> OuroborosApplication mode initiatorCtx responderCtx bytes m a b + -> OuroborosApplication mode networkState initiatorCtx responderCtx bytes m a b -> [MiniProtocolInfo mode] toMiniProtocolInfos forkPolicy = foldMap (mkMiniProtocolInfo forkPolicy) . getOuroborosApplication contramapInitiatorCtx :: (initiatorCtx' -> initiatorCtx) - -> OuroborosApplication mode initiatorCtx responderCtx bytes m a b - -> OuroborosApplication mode initiatorCtx' responderCtx bytes m a b + -> OuroborosApplication mode initiatorCtx responderCtx networkState bytes m a b + -> OuroborosApplication mode initiatorCtx' responderCtx networkState bytes m a b contramapInitiatorCtx f (OuroborosApplication ptcls) = OuroborosApplication [ ptcl { miniProtocolRun = case miniProtocolRun ptcl of @@ -494,6 +498,8 @@ contramapInitiatorCtx f (OuroborosApplication ptcls) = OuroborosApplication InitiatorProtocolOnly (contramapMiniProtocolCbCtx f initiator) ResponderProtocolOnly responder -> ResponderProtocolOnly responder + ResponderProtocolOnlyWithState responder -> + ResponderProtocolOnlyWithState responder InitiatorAndResponderProtocol initiator responder -> InitiatorAndResponderProtocol (contramapMiniProtocolCbCtx f initiator) responder } @@ -505,7 +511,7 @@ contramapInitiatorCtx f (OuroborosApplication ptcls) = OuroborosApplication -- 'newMux'. -- mkMiniProtocolInfos :: ForkPolicyCb - -> OuroborosBundle mode initiatorCtx responderCtx bytes m a b + -> OuroborosBundle mode initiatorCtx responderCtx networkState bytes m a b -> [MiniProtocolInfo mode] mkMiniProtocolInfos forkPolicy = foldMap (foldMap (mkMiniProtocolInfo forkPolicy)) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs index 3b313ca0f7..c503db6a10 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs @@ -75,8 +75,8 @@ data Arguments (muxMode :: Mx.Mode) socket initiatorCtx networkState peerAddr v inboundGovernorTracer :: Tracer m (InboundGovernor.Trace peerAddr), debugInboundGovernor :: Tracer m (InboundGovernor.Debug peerAddr versionData), connectionLimits :: AcceptedConnectionsLimit, - connectionManager :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr) - peerAddr versionData versionNumber bytes m a b, + connectionManager :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr) networkState + peerAddr versionData versionNumber bytes m a b, -- | Time for which all protocols need to be idle to trigger -- 'DemotedToCold' transition. @@ -89,8 +89,8 @@ data Arguments (muxMode :: Mx.Mode) socket initiatorCtx networkState peerAddr v -- server to run and manage responders which needs to be started on -- inbound connections. -- - inboundInfoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData - bytes m a b, + inboundInfoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx networkState peerAddr versionData + bytes m a b, -- | read public state readNetworkState :: m networkState diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index 8700072b4e..f939413f5f 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -127,9 +127,9 @@ debuggingNetworkConnectTracers = NetworkConnectTracers { sockAddrFamily :: Socket.SockAddr -> Socket.Family -sockAddrFamily (Socket.SockAddrInet _ _ ) = Socket.AF_INET -sockAddrFamily (Socket.SockAddrInet6 _ _ _ _) = Socket.AF_INET6 -sockAddrFamily (Socket.SockAddrUnix _ ) = Socket.AF_UNIX +sockAddrFamily Socket.SockAddrInet{} = Socket.AF_INET +sockAddrFamily Socket.SockAddrInet6{} = Socket.AF_INET6 +sockAddrFamily Socket.SockAddrUnix{} = Socket.AF_UNIX -- | Configure a socket. Either 'Socket.AF_INET' or 'Socket.AF_INET6' socket @@ -243,7 +243,7 @@ data ConnectToArgs fd addr vNumber vData = ConnectToArgs { -- -- Exceptions thrown by 'MuxApplication' are rethrown by 'connectToNode'. connectToNode - :: forall muxMode vNumber vData fd addr a b. + :: forall muxMode networkState vNumber vData fd addr a b. ( Ord vNumber , Typeable vNumber , Show vNumber @@ -253,7 +253,7 @@ connectToNode -> Mx.MakeBearer IO fd -> ConnectToArgs fd addr vNumber vData -> (fd -> IO ()) -- ^ configure socket - -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString IO a b) + -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString IO a b) -> Maybe addr -- ^ local address; the created socket will bind to it -> addr @@ -266,7 +266,7 @@ connectToNode sn mkBearer args configureSock versions localAddr remoteAddr = -- | A version `connectToNode` which allows one to control which mini-protocols -- to execute on a given connection. connectToNodeWithMux - :: forall muxMode vNumber vData fd addr a b x. + :: forall muxMode networkState vNumber vData fd addr a b x. ( Ord vNumber , Typeable vNumber , Show vNumber @@ -276,7 +276,7 @@ connectToNodeWithMux -> Mx.MakeBearer IO fd -> ConnectToArgs fd addr vNumber vData -> (fd -> IO ()) -- ^ configure socket - -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString IO a b) + -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString IO a b) -- ^ application to run over the connection -- ^ remote address -> Maybe addr @@ -284,7 +284,7 @@ connectToNodeWithMux -> ( ConnectionId addr -> vNumber -> vData - -> OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString IO a b + -> OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString IO a b -> Mx.Mux muxMode IO -> Async IO () -> IO x) @@ -315,7 +315,7 @@ connectToNodeWithMux sn mkBearer args configureSock versions localAddr remoteAdd -- -- Exceptions thrown by @'MuxApplication'@ are rethrown by @'connectTo'@. connectToNode' - :: forall muxMode vNumber vData fd addr a b. + :: forall muxMode networkState vNumber vData fd addr a b. ( Ord vNumber , Typeable vNumber , Show vNumber @@ -325,7 +325,7 @@ connectToNode' -> Mx.MakeBearer IO fd -> ConnectToArgs fd addr vNumber vData -- ^ a configured socket to use to connect to a remote service provider - -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString IO a b) + -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString IO a b) -- ^ application to run over the connection -> fd -> IO (Either SomeException (Either a b)) @@ -334,7 +334,7 @@ connectToNode' sn mkBearer args versions as = connectToNodeWithMux' - :: forall muxMode vNumber vData fd addr a b x. + :: forall muxMode networkState vNumber vData fd addr a b x. ( Ord vNumber , Typeable vNumber , Show vNumber @@ -343,14 +343,14 @@ connectToNodeWithMux' => Snocket IO fd addr -> Mx.MakeBearer IO fd -> ConnectToArgs fd addr vNumber vData - -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString IO a b) + -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString IO a b) -- ^ application to run over the connection -- ^ a configured socket to use to connect to a remote service provider -> fd -> ( ConnectionId addr -> vNumber -> vData - -> OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString IO a b + -> OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString IO a b -> Mx.Mux muxMode IO -> Async IO () -> IO x) @@ -420,8 +420,10 @@ connectToNodeWithMux' -- until the first one terminates. It returns the result (or error) of the -- first terminated mini-protocol. -- +-- NOTE: `simpleMuxCallback` does not support `ResponderProtocolOnlyWithState`. +-- simpleMuxCallback - :: forall muxMode addr vNumber vData m a b. + :: forall muxMode networkState addr vNumber vData m a b. ( Alternative (STM m) , MonadAsync m , MonadSTM m @@ -431,7 +433,7 @@ simpleMuxCallback => ConnectionId addr -> vNumber -> vData - -> OuroborosApplicationWithMinimalCtx muxMode addr BL.ByteString m a b + -> OuroborosApplicationWithMinimalCtx muxMode networkState addr BL.ByteString m a b -> Mx.Mux muxMode m -> Async m () -> m (Either SomeException (Either a b)) @@ -454,6 +456,8 @@ simpleMuxCallback connectionId _ _ app mux aid = do [(Mx.InitiatorDirectionOnly, fmap (first Left) . runMiniProtocolCb initiator initCtx)] ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, fmap (first Right) . runMiniProtocolCb responder respCtx)] + ResponderProtocolOnlyWithState _ -> + error "simpleMuxCallback: does not support ResponderProtocolOnlyWithState" InitiatorAndResponderProtocol initiator responder -> [(Mx.InitiatorDirection, fmap (first Left) . runMiniProtocolCb initiator initCtx) ,(Mx.ResponderDirection, fmap (first Right) . runMiniProtocolCb responder respCtx)] @@ -471,7 +475,7 @@ simpleMuxCallback connectionId _ _ app mux aid = do -- Wraps a Socket inside a Snocket and calls connectToNode' connectToNodeSocket - :: forall muxMode vNumber vData a b. + :: forall muxMode networkState vNumber vData a b. ( Ord vNumber , Typeable vNumber , Show vNumber @@ -479,7 +483,7 @@ connectToNodeSocket ) => IOManager -> ConnectToArgs Socket.Socket Socket.SockAddr vNumber vData - -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode Socket.SockAddr BL.ByteString IO a b) + -> Versions vNumber vData (OuroborosApplicationWithMinimalCtx muxMode networkState Socket.SockAddr BL.ByteString IO a b) -- ^ application to run over the connection -> Socket.Socket -> IO (Either SomeException (Either a b)) @@ -496,7 +500,7 @@ connectToNodeSocket iocp args versions sd = -- data SomeResponderApplication addr bytes m b where SomeResponderApplication - :: forall muxMode addr bytes m a b. + :: forall muxMode networkState addr bytes m a b. Mx.HasResponder muxMode ~ True - => (OuroborosApplicationWithMinimalCtx muxMode addr bytes m a b) + => (OuroborosApplicationWithMinimalCtx muxMode networkState addr bytes m a b) -> SomeResponderApplication addr bytes m b diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 168b624437..6065d1439b 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -270,7 +270,7 @@ withInitiatorOnlyConnectionManager -- ^ Handshake time limits -> AcceptedConnectionsLimit -> (ConnectionManagerWithExpandedCtx - Mx.InitiatorMode socket peerAddr + Mx.InitiatorMode socket () peerAddr DataFlowProtocolData UnversionedProtocol ByteString m [resp] Void -> m a) -> m a @@ -329,7 +329,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket [MiniProtocol Mx.InitiatorMode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - ByteString m [resp] Void] + () ByteString m [resp] Void] clientApplication = mkProto <$> (Mx.MiniProtocolNum <$> nums) <*> nextRequests @@ -348,7 +348,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket -> RunMiniProtocol Mx.InitiatorMode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - ByteString m [resp] Void + () ByteString m [resp] Void reqRespInitiator protocolNum nextRequest = InitiatorProtocolOnly (MiniProtocolCb $ \ExpandedInitiatorContext { eicConnectionId = connId } channel -> @@ -450,7 +450,7 @@ withBidirectionalConnectionManager -- ^ Handshake time limits -> AcceptedConnectionsLimit -> (ConnectionManagerWithExpandedCtx - Mx.InitiatorResponderMode socket peerAddr + Mx.InitiatorResponderMode socket () peerAddr DataFlowProtocolData UnversionedProtocol ByteString m [resp] acc -> peerAddr -> Async m Void @@ -549,7 +549,7 @@ withBidirectionalConnectionManager name timeouts [MiniProtocol Mx.InitiatorResponderMode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - ByteString m [resp] acc] + () ByteString m [resp] acc] serverApplication = mkProto <$> (Mx.MiniProtocolNum <$> nums) <*> nextRequests where nums = TemperatureBundle (WithHot 1) (WithWarm 2) (WithEstablished 3) mkProto miniProtocolNum nextRequest = @@ -570,7 +570,7 @@ withBidirectionalConnectionManager name timeouts -> RunMiniProtocol Mx.InitiatorResponderMode (ExpandedInitiatorContext peerAddr m) (ResponderContext peerAddr) - ByteString m [resp] acc + () ByteString m [resp] acc reqRespInitiatorAndResponder protocolNum accInit nextRequest = InitiatorAndResponderProtocol (MiniProtocolCb $ \ExpandedInitiatorContext { eicConnectionId = connId } channel -> @@ -655,7 +655,7 @@ runInitiatorProtocols -> Mx.Mux muxMode m -> OuroborosBundle muxMode (ExpandedInitiatorContext addr m) (ResponderContext addr) - ByteString m a b + () ByteString m a b -> TemperatureBundle (StrictTVar m ControlMessage) -> ConnectionId addr -> m (TemperatureBundle a) @@ -667,7 +667,7 @@ runInitiatorProtocols singMuxMode mux bundle controlBundle connId = do traverse (atomically >=> either throwIO return) bundle' where - runInitiator :: MiniProtocolWithExpandedCtx muxMode addr ByteString m a b + runInitiator :: MiniProtocolWithExpandedCtx muxMode () addr ByteString m a b -> ControlMessageSTM m -> m (STM m (Either SomeException a)) runInitiator ptcl controlMessage = @@ -763,7 +763,7 @@ unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clie (\connHandle -> do case connHandle of Connected connId _ (Handle mux muxBundle controlBundle _ - :: HandleWithExpandedCtx Mx.InitiatorMode peerAddr + :: HandleWithExpandedCtx Mx.InitiatorMode () peerAddr DataFlowProtocolData ByteString m [resp] Void) -> try @_ @SomeException $ (runInitiatorProtocols diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index dfe73191fa..3a35819cf6 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -81,6 +81,7 @@ import Ouroboros.Network.DeltaQ (defaultGSV) import Ouroboros.Network.Server.Simple qualified as Server.Simple +type NetworkState = () data Options = Options { oBlockFetch :: Bool, @@ -218,8 +219,8 @@ maximumMiniProtocolLimits = -- demoProtocol2 - :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b -- ^ chainSync - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b + :: RunMiniProtocolWithMinimalCtx appType NetworkState addr bytes m a b -- ^ chainSync + -> OuroborosApplicationWithMinimalCtx appType NetworkState addr bytes m a b demoProtocol2 chainSync = OuroborosApplication [ MiniProtocol { @@ -256,7 +257,7 @@ clientChainSync sockPaths maxSlotNo = withIOManager $ \iocp -> (localAddressFromPath sockPath) where - app :: OuroborosApplicationWithMinimalCtx Mx.InitiatorMode addr LBS.ByteString IO () Void + app :: OuroborosApplicationWithMinimalCtx Mx.InitiatorMode NetworkState addr LBS.ByteString IO () Void app = demoProtocol2 $ InitiatorProtocolOnly $ mkMiniProtocolCbFromPeer $ \_ctx -> @@ -295,7 +296,7 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do wait serverAsync -- block until async exception where app :: StdGen - -> OuroborosApplicationWithMinimalCtx Mx.ResponderMode addr LBS.ByteString IO Void () + -> OuroborosApplicationWithMinimalCtx Mx.ResponderMode NetworkState addr LBS.ByteString IO Void () app prng = demoProtocol2 $ ResponderProtocolOnly $ mkMiniProtocolCbFromPeer $ \_ctx -> @@ -324,9 +325,9 @@ codecChainSync = -- demoProtocol3 - :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b -- ^ chainSync - -> RunMiniProtocolWithMinimalCtx appType addr bytes m a b -- ^ blockFetch - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b + :: RunMiniProtocolWithMinimalCtx appType NetworkState addr bytes m a b -- ^ chainSync + -> RunMiniProtocolWithMinimalCtx appType NetworkState addr bytes m a b -- ^ blockFetch + -> OuroborosApplicationWithMinimalCtx appType NetworkState addr bytes m a b demoProtocol3 chainSync blockFetch = OuroborosApplication [ MiniProtocol { @@ -377,11 +378,11 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do app :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode LocalAddress LBS.ByteString IO () Void + Mx.InitiatorMode NetworkState LocalAddress LBS.ByteString IO () Void app = demoProtocol3 chainSync blockFetch chainSync :: RunMiniProtocolWithMinimalCtx - Mx.InitiatorMode LocalAddress LBS.ByteString IO () Void + Mx.InitiatorMode NetworkState LocalAddress LBS.ByteString IO () Void chainSync = InitiatorProtocolOnly $ MiniProtocolCb $ \MinimalInitiatorContext { micConnectionId = connId } channel -> @@ -403,7 +404,7 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do (chainSyncClient' continueUntilMaxSlot maxSlotNo syncTracer currentChainVar chainVar)) blockFetch :: RunMiniProtocolWithMinimalCtx - Mx.InitiatorMode LocalAddress LBS.ByteString IO () Void + Mx.InitiatorMode NetworkState LocalAddress LBS.ByteString IO () Void blockFetch = InitiatorProtocolOnly $ MiniProtocolCb $ \MinimalInitiatorContext { micConnectionId = connId } channel -> @@ -570,12 +571,12 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do where app :: StdGen -> OuroborosApplicationWithMinimalCtx - Mx.ResponderMode LocalAddress LBS.ByteString IO Void () + Mx.ResponderMode NetworkState LocalAddress LBS.ByteString IO Void () app prng = demoProtocol3 (chainSync prng) (blockFetch prng) chainSync :: StdGen -> RunMiniProtocolWithMinimalCtx - Mx.ResponderMode LocalAddress LBS.ByteString IO Void () + Mx.ResponderMode NetworkState LocalAddress LBS.ByteString IO Void () chainSync prng = ResponderProtocolOnly $ mkMiniProtocolCbFromPeer $ \_ctx -> @@ -586,7 +587,7 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do blockFetch :: StdGen -> RunMiniProtocolWithMinimalCtx - Mx.ResponderMode LocalAddress LBS.ByteString IO Void () + Mx.ResponderMode NetworkState LocalAddress LBS.ByteString IO Void () blockFetch prng = ResponderProtocolOnly $ mkMiniProtocolCbFromPeer $ \_ctx -> diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs index 0b92e3cd97..20a4b25b1d 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs @@ -69,6 +69,8 @@ tests = testGroup "Pipe" [ testProperty "pipe sync demo" (withMaxSuccess 32 prop_pipe_demo) ] +type NetworkState = () + -- -- Properties -- @@ -82,8 +84,8 @@ defaultMiniProtocolLimit = 3000000 -- | The bundle of mini-protocols in our demo protocol: only chain sync -- -demoProtocols :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +demoProtocols :: RunMiniProtocolWithMinimalCtx appType NetworkState addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType NetworkState addr bytes m a b demoProtocols chainSync = OuroborosApplication [ MiniProtocol { @@ -164,7 +166,7 @@ demo chain0 updates = do target = Chain.headPoint expectedChain consumerApp :: OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode String BL.ByteString IO () Void + Mx.InitiatorMode NetworkState String BL.ByteString IO () Void consumerApp = demoProtocols chainSyncInitator chainSyncInitator = @@ -182,7 +184,7 @@ demo chain0 updates = do server = ChainSync.chainSyncServerExample () producerVar id producerApp ::OuroborosApplicationWithMinimalCtx - Mx.ResponderMode String BL.ByteString IO Void () + Mx.ResponderMode NetworkState String BL.ByteString IO Void () producerApp = demoProtocols chainSyncResponder chainSyncResponder = @@ -241,6 +243,9 @@ demo chain0 updates = do case miniProtocolRun of ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] + + ResponderProtocolOnlyWithState {} -> + error "quering network state is not supported" ] withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs index 82d91784bc..6d6bcf5b17 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs @@ -71,14 +71,15 @@ tests = [ testProperty "socket sync demo" prop_socket_demo ] +type NetworkState = () defaultMiniProtocolLimit :: Int defaultMiniProtocolLimit = 3000000 -- | The bundle of mini-protocols in our test protocol: only chain sync -- -testProtocols1 :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +testProtocols1 :: RunMiniProtocolWithMinimalCtx appType NetworkState addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType NetworkState addr bytes m a b testProtocols1 chainSync = OuroborosApplication [ MiniProtocol { @@ -126,7 +127,8 @@ demo chain0 updates = withIOManager $ \iocp -> do target = Chain.headPoint expectedChain initiatorApp - :: OuroborosApplicationWithMinimalCtx Mx.InitiatorMode Socket.SockAddr + :: OuroborosApplicationWithMinimalCtx Mx.InitiatorMode NetworkState + Socket.SockAddr BL.ByteString IO () Void initiatorApp = testProtocols1 chainSyncInitator @@ -143,7 +145,8 @@ demo chain0 updates = withIOManager $ \iocp -> do server = ChainSync.chainSyncServerExample () producerVar id responderApp - :: OuroborosApplicationWithMinimalCtx Mx.ResponderMode Socket.SockAddr + :: OuroborosApplicationWithMinimalCtx Mx.ResponderMode NetworkState + Socket.SockAddr BL.ByteString IO Void () responderApp = testProtocols1 chainSyncResponder diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 54ee2c6864..7ee614916a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -500,9 +500,9 @@ runM Interfaces :: forall muxMode socket initiatorCtx responderCtx b c. SingMuxMode muxMode -> Versions ntnVersion ntnVersionData - (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) + (OuroborosBundle muxMode initiatorCtx responderCtx NetworkState ByteString m b c) -> MuxConnectionHandler - muxMode socket initiatorCtx responderCtx ntnAddr + muxMode socket initiatorCtx responderCtx NetworkState ntnAddr ntnVersion ntnVersionData ByteString m b c makeConnectionHandler' muxMode versions = makeConnectionHandler @@ -552,11 +552,11 @@ runM Interfaces HasInitiator muxMode ~ True => MuxConnectionManager muxMode socket (ExpandedInitiatorContext ntnAddr m) - responderCtx ntnAddr ntnVersionData ntnVersion + responderCtx NetworkState ntnAddr ntnVersionData ntnVersion ByteString m a b -> (Governor.PeerStateActions ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr + (PeerConnectionHandle muxMode responderCtx NetworkState ntnAddr ntnVersionData ByteString m a b) m -> m c) @@ -585,13 +585,14 @@ runM Interfaces -- let withPeerSelectionActions' - :: m (Map ntnAddr PeerSharing) + :: forall muxMode responderCtx bytes a' b c. + m (Map ntnAddr PeerSharing) -> PeerStateActions ntnAddr (PeerConnectionHandle - muxMode responderCtx ntnAddr ntnVersionData bytes m a b) + muxMode responderCtx NetworkState ntnAddr ntnVersionData bytes m a' b) m - -> ((Async m Void, Async m Void) + -> ( (Async m Void, Async m Void) -> PeerSelectionActions extraState extraFlags @@ -600,7 +601,7 @@ runM Interfaces extraCounters ntnAddr (PeerConnectionHandle - muxMode responderCtx ntnAddr ntnVersionData bytes m a b) + muxMode responderCtx NetworkState ntnAddr ntnVersionData bytes m a' b) m -> m c) -> m c @@ -652,11 +653,11 @@ runM Interfaces peerSelectionGovernor' :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) -> StrictTVar m (PeerSelectionState extraState extraFlags extraPeers ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData ByteString m a b)) + (PeerConnectionHandle muxMode responderCtx NetworkState ntnAddr ntnVersionData ByteString m a b)) -> PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData ByteString m a b) + (PeerConnectionHandle muxMode responderCtx NetworkState ntnAddr ntnVersionData ByteString m a b) m -> m Void peerSelectionGovernor' peerSelectionTracer dbgVar peerSelectionActions = diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs index 714318163e..56429e5e27 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -23,6 +23,7 @@ module Ouroboros.Network.Diffusion.Types , NodeToClientConnectionHandler , NodeToClientConnectionManagerArguments -- * NodeToNode type aliases + , NetworkState , NodeToNodeHandle , NodeToNodeConnectionManager , NodeToNodePeerConnectionHandle @@ -104,6 +105,8 @@ data DiffusionTracer ntnAddr ntcAddr | SystemdSocketConfiguration SystemdSocketTracer deriving Show +type NetworkState = () + -- TODO: add a tracer for these misconfiguration data Failure where UnsupportedReadySocket :: Failure @@ -352,7 +355,7 @@ data Arguments extraState extraDebugState extraFlags extraPeers PeerSelectionGovernorArgs extraState extraDebugState extraFlags extraPeers extraAPI extraCounters ntnAddr (PeerConnectionHandle - muxMode responderCtx ntnAddr + muxMode responderCtx NetworkState ntnAddr ntnVersionData bytes m a b) exception m @@ -362,7 +365,7 @@ data Arguments extraState extraDebugState extraFlags extraPeers :: forall muxMode responderCtx ntnVersionData bytes a b . PeerSelectionState extraState extraFlags extraPeers ntnAddr (PeerConnectionHandle - muxMode responderCtx ntnAddr + muxMode responderCtx NetworkState ntnAddr ntnVersionData bytes m a b) -> extraCounters @@ -434,7 +437,7 @@ data Applications ntnAddr ntnVersion ntnVersionData :: Versions ntnVersion ntnVersionData (OuroborosBundleWithExpandedCtx - Mx.InitiatorMode ntnAddr + Mx.InitiatorMode () ntnAddr ByteString m a Void) -- | NodeToNode initiator & responder applications for bidirectional mode. @@ -444,7 +447,7 @@ data Applications ntnAddr ntnVersion ntnVersionData :: Versions ntnVersion ntnVersionData (OuroborosBundleWithExpandedCtx - Mx.InitiatorResponderMode ntnAddr + Mx.InitiatorResponderMode () ntnAddr ByteString m a ()) -- | NodeToClient responder application (server role) @@ -455,7 +458,7 @@ data Applications ntnAddr ntnVersion ntnVersionData :: Versions ntcVersion ntcVersionData (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode ntcAddr + Mx.ResponderMode () ntcAddr ByteString m Void ()) -- | Interface used to get peers from the current ledger. @@ -497,7 +500,7 @@ data Applications ntnAddr ntnVersion ntnVersionData -- type NodeToClientHandle ntcAddr versionData m = - HandleWithMinimalCtx Mx.ResponderMode ntcAddr versionData ByteString m Void () + HandleWithMinimalCtx Mx.ResponderMode NetworkState ntcAddr versionData ByteString m Void () type NodeToClientHandleError ntcVersion = HandleError Mx.ResponderMode ntcVersion @@ -537,7 +540,7 @@ type NodeToClientConnectionManagerArguments type NodeToNodeHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = - HandleWithExpandedCtx mode ntnAddr ntnVersionData ByteString m a b + HandleWithExpandedCtx mode NetworkState ntnAddr ntnVersionData ByteString m a b type NodeToNodeConnectionManager (mode :: Mx.Mode) @@ -558,6 +561,7 @@ type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a PeerConnectionHandle mode (ResponderContext ntnAddr) + NetworkState ntnAddr ntnVersionData ByteString diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index d6655827e4..9260d05b1b 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -99,22 +99,22 @@ data NodeToClientProtocols appType ntcAddr bytes m a b = NodeToClientProtocols { -- | local chain-sync mini-protocol -- localChainSyncProtocol :: RunMiniProtocolWithMinimalCtx - appType ntcAddr bytes m a b, + appType () ntcAddr bytes m a b, -- | local tx-submission mini-protocol -- localTxSubmissionProtocol :: RunMiniProtocolWithMinimalCtx - appType ntcAddr bytes m a b, + appType () ntcAddr bytes m a b, -- | local state-query mini-protocol -- localStateQueryProtocol :: RunMiniProtocolWithMinimalCtx - appType ntcAddr bytes m a b, + appType () ntcAddr bytes m a b, -- | local tx-monitor mini-protocol -- localTxMonitorProtocol :: RunMiniProtocolWithMinimalCtx - appType ntcAddr bytes m a b + appType () ntcAddr bytes m a b } @@ -133,7 +133,7 @@ nodeToClientProtocols :: NodeToClientProtocols appType addr bytes m a b -> NodeToClientVersion -> NodeToClientVersionData - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b nodeToClientProtocols protocols _version _versionData = OuroborosApplication $ case protocols of @@ -190,7 +190,7 @@ versionedNodeToClientProtocols -> NodeToClientProtocols appType LocalAddress bytes m a b -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx appType LocalAddress bytes m a b) + (OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a b) versionedNodeToClientProtocols versionNumber versionData protocols = simpleSingletonVersions versionNumber @@ -208,7 +208,7 @@ connectTo -> Versions NodeToClientVersion NodeToClientVersionData (OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode LocalAddress BL.ByteString IO a Void) + Mx.InitiatorMode () LocalAddress BL.ByteString IO a Void) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). @@ -246,7 +246,7 @@ connectToWithMux -> Versions NodeToClientVersion NodeToClientVersionData (OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode LocalAddress BL.ByteString IO a b) + Mx.InitiatorMode () LocalAddress BL.ByteString IO a b) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). @@ -255,7 +255,7 @@ connectToWithMux -> ( ConnectionId LocalAddress -> NodeToClientVersion -> NodeToClientVersionData - -> OuroborosApplicationWithMinimalCtx Mx.InitiatorMode LocalAddress BL.ByteString IO a b + -> OuroborosApplicationWithMinimalCtx Mx.InitiatorMode () LocalAddress BL.ByteString IO a b -> Mx.Mux Mx.InitiatorMode IO -> Async.Async () -> IO x) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 2628a4d4b5..1c9c461f0f 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -5,7 +5,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -107,33 +106,33 @@ type HandshakeTr ntnAddr ntnVersion = (TraceSendRecv (Handshake ntnVersion CBOR.Term)) -data NodeToNodeProtocols appType initiatorCtx responderCtx bytes m a b = NodeToNodeProtocols { +data NodeToNodeProtocols appType initiatorCtx responderCtx peerAddr bytes m a b = NodeToNodeProtocols { -- | chain-sync mini-protocol -- - chainSyncProtocol :: RunMiniProtocol appType initiatorCtx responderCtx bytes m a b, + chainSyncProtocol :: RunMiniProtocol appType initiatorCtx responderCtx peerAddr bytes m a b, -- | block-fetch mini-protocol -- - blockFetchProtocol :: RunMiniProtocol appType initiatorCtx responderCtx bytes m a b, + blockFetchProtocol :: RunMiniProtocol appType initiatorCtx responderCtx peerAddr bytes m a b, -- | tx-submission mini-protocol -- - txSubmissionProtocol :: RunMiniProtocol appType initiatorCtx responderCtx bytes m a b, + txSubmissionProtocol :: RunMiniProtocol appType initiatorCtx responderCtx peerAddr bytes m a b, -- | keep-alive mini-protocol -- - keepAliveProtocol :: RunMiniProtocol appType initiatorCtx responderCtx bytes m a b, + keepAliveProtocol :: RunMiniProtocol appType initiatorCtx responderCtx peerAddr bytes m a b, -- | peer sharing mini-protocol -- - peerSharingProtocol :: RunMiniProtocol appType initiatorCtx responderCtx bytes m a b + peerSharingProtocol :: RunMiniProtocol appType initiatorCtx responderCtx peerAddr bytes m a b } type NodeToNodeProtocolsWithExpandedCtx appType ntnAddr bytes m a b = - NodeToNodeProtocols appType (ExpandedInitiatorContext ntnAddr m) (ResponderContext ntnAddr) bytes m a b + NodeToNodeProtocols appType (ExpandedInitiatorContext ntnAddr m) (ResponderContext ntnAddr) ntnAddr bytes m a b type NodeToNodeProtocolsWithMinimalCtx appType ntnAddr bytes m a b = - NodeToNodeProtocols appType (MinimalInitiatorContext ntnAddr) (ResponderContext ntnAddr) bytes m a b + NodeToNodeProtocols appType (MinimalInitiatorContext ntnAddr) (ResponderContext ntnAddr) ntnAddr bytes m a b data MiniProtocolParameters = MiniProtocolParameters { @@ -187,12 +186,12 @@ defaultMiniProtocolParameters = MiniProtocolParameters { -- nodeToNodeProtocols :: MiniProtocolParameters - -> NodeToNodeProtocols muxMode initiatorCtx responderCtx bytes m a b + -> NodeToNodeProtocols muxMode initiatorCtx responderCtx peerAddr bytes m a b -> NodeToNodeVersion -- ^ negotiated version number -> NodeToNodeVersionData -- ^ negotiated version data - -> OuroborosBundle muxMode initiatorCtx responderCtx bytes m a b + -> OuroborosBundle muxMode initiatorCtx responderCtx peerAddr bytes m a b nodeToNodeProtocols miniProtocolParameters protocols _version NodeToNodeVersionData { peerSharing } = @@ -398,7 +397,7 @@ connectTo -> Versions NodeToNodeVersion NodeToNodeVersionData (OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode Socket.SockAddr BL.ByteString IO a b) + Mx.InitiatorMode () Socket.SockAddr BL.ByteString IO a b) -> Maybe Socket.SockAddr -> Socket.SockAddr -> IO (Either SomeException (Either a b)) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index ec4bc45deb..3830e61f78 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -801,16 +801,23 @@ makeDebugPeerSelectionState PeerSelectionState {..} up bp es am = -- This data type should not expose too much information and keep only -- essential data needed for computing the peer sharing request result -- -newtype PublicPeerSelectionState peeraddr = +data PublicPeerSelectionState peeraddr = PublicPeerSelectionState { - availableToShare :: Set peeraddr - } + availableToShare :: Set peeraddr, + knownSet :: Set peeraddr, + establishedSet :: Set peeraddr, + activeSet :: Set peeraddr + } + deriving Show emptyPublicPeerSelectionState :: Ord peeraddr => PublicPeerSelectionState peeraddr emptyPublicPeerSelectionState = PublicPeerSelectionState { - availableToShare = mempty + availableToShare = mempty, + knownSet = mempty, + establishedSet = mempty, + activeSet = mempty } makePublicPeerSelectionStateVar @@ -825,10 +832,13 @@ makePublicPeerSelectionStateVar = newTVarIO emptyPublicPeerSelectionState -- toPublicState :: PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn -> PublicPeerSelectionState peeraddr -toPublicState PeerSelectionState { knownPeers } = +toPublicState PeerSelectionState { knownPeers, establishedPeers, activePeers } = PublicPeerSelectionState { availableToShare = - KnownPeers.getPeerSharingResponsePeers knownPeers + KnownPeers.getPeerSharingResponsePeers knownPeers, + knownSet = KnownPeers.toSet knownPeers, + establishedSet = EstablishedPeers.toSet establishedPeers, + activeSet = activePeers } -- | Peer selection view. diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs index bab41e8e85..22c28e4bc3 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs @@ -285,11 +285,11 @@ instance Exception MiniProtocolExceptions -- -- TODO: only for hot applications we need 'ahApplication', we never restart -- / stop the other ones! -data ApplicationHandle muxMode responderCtx peerAddr bytes m a b = ApplicationHandle { +data ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b = ApplicationHandle { -- | List of applications for the given peer temperature. -- ahApplication :: [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m) - responderCtx bytes m a b], + responderCtx networkState bytes m a b], -- | 'ControlMessage' 'TVar' for the given peer temperature. -- @@ -308,17 +308,17 @@ data ApplicationHandle muxMode responderCtx peerAddr bytes m a b = ApplicationHa -- getControlVar :: SingProtocolTemperature pt - -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b) + -> TemperatureBundle (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b) -> StrictTVar m ControlMessage getControlVar tok = ahControlVar . projectBundle tok getProtocols :: SingProtocolTemperature pt - -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b) - -> [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m) responderCtx bytes m a b] + -> TemperatureBundle (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b) + -> [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m) responderCtx networkState bytes m a b] getProtocols tok bundle = ahApplication (projectBundle tok bundle) getMiniProtocolsVar :: SingProtocolTemperature pt - -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b) + -> TemperatureBundle (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b) -> StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a))) getMiniProtocolsVar tok = ahMiniProtocolResults . projectBundle tok @@ -353,7 +353,7 @@ instance Semigroup FirstToFinishResult where -- awaitFirstResult :: MonadSTM m => SingProtocolTemperature pt - -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b) + -> TemperatureBundle (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b) -> STM m FirstToFinishResult awaitFirstResult tok bundle = do d <- readTVar (getMiniProtocolsVar tok bundle) @@ -401,7 +401,7 @@ instance Monoid (LastToFinishResult a) where -- awaitAllResults :: MonadSTM m => SingProtocolTemperature pt - -> TemperatureBundle (ApplicationHandle muxMude responderCtx peerAddr bytes m a b) + -> TemperatureBundle (ApplicationHandle muxMude responderCtx networkState peerAddr bytes m a b) -> STM m (LastToFinishResult a) awaitAllResults tok bundle = do results <- readTVar (getMiniProtocolsVar tok bundle) @@ -425,18 +425,18 @@ awaitAllResults tok bundle = do -- 'Mux', three bundles of miniprotocols: for hot, warm and established peers -- together with their state 'StrictTVar's. -- -data PeerConnectionHandle (muxMode :: Mux.Mode) responderCtx peerAddr versionData bytes m a b = PeerConnectionHandle { +data PeerConnectionHandle (muxMode :: Mux.Mode) responderCtx networkState peerAddr versionData bytes m a b = PeerConnectionHandle { pchConnectionId :: ConnectionId peerAddr, pchPeerStatus :: StrictTVar m PeerStatus, pchMux :: Mux.Mux muxMode m, - pchAppHandles :: TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b), + pchAppHandles :: TemperatureBundle (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b), pchVersionData :: !versionData } mkInitiatorContext :: MonadSTM m => SingProtocolTemperature pt -> IsBigLedgerPeer - -> PeerConnectionHandle muxMode responderCtx peerAddr versionDat bytes m a b + -> PeerConnectionHandle muxMode responderCtx networkState peerAddr versionDat bytes m a b -> ExpandedInitiatorContext peerAddr m mkInitiatorContext tok isBigLedgerPeer PeerConnectionHandle { @@ -452,12 +452,12 @@ mkInitiatorContext tok isBigLedgerPeer instance (Show peerAddr, Show versionData) - => Show (PeerConnectionHandle muxMode responderCtx peerAddr versionData bytes m a b) where + => Show (PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData bytes m a b) where show PeerConnectionHandle { pchConnectionId, pchVersionData } = "PeerConnectionHandle " ++ show pchConnectionId ++ " " ++ show pchVersionData pchPeerSharing :: (versionData -> PeerSharing) - -> PeerConnectionHandle muxMode responderCtx peerAddr versionData bytes m a b + -> PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData bytes m a b -> PeerSharing pchPeerSharing f = f . pchVersionData @@ -536,7 +536,7 @@ instance ( Show peerAddr -- | Record of arguments of 'peerSelectionActions'. -- -data PeerStateActionsArguments muxMode socket responderCtx peerAddr versionData versionNumber m a b = +data PeerStateActionsArguments muxMode socket responderCtx networkState peerAddr versionData versionNumber m a b = PeerStateActionsArguments { spsTracer :: Tracer m (PeerSelectionActionsTrace peerAddr versionNumber), @@ -552,7 +552,7 @@ data PeerStateActionsArguments muxMode socket responderCtx peerAddr versionData spsConnectionManager :: MuxConnectionManager muxMode socket (ExpandedInitiatorContext peerAddr m) - responderCtx peerAddr + responderCtx networkState peerAddr versionData versionNumber ByteString m a b, @@ -563,7 +563,7 @@ data PeerStateActionsArguments muxMode socket responderCtx peerAddr versionData withPeerStateActions - :: forall (muxMode :: Mux.Mode) socket responderCtx peerAddr versionData versionNumber m a b x. + :: forall (muxMode :: Mux.Mode) socket responderCtx networkState peerAddr versionData versionNumber m a b x. ( Alternative (STM m) , MonadAsync m , MonadCatch m @@ -579,10 +579,10 @@ withPeerStateActions , Typeable peerAddr , Show peerAddr ) - => PeerStateActionsArguments muxMode socket responderCtx peerAddr versionData versionNumber m a b + => PeerStateActionsArguments muxMode socket responderCtx networkState peerAddr versionData versionNumber m a b -> (PeerStateActions peerAddr - (PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b) + (PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b) m -> m x) -> m x @@ -622,7 +622,7 @@ withPeerStateActions PeerStateActionsArguments { (> PeerCooling) <$> readTVar stateVar peerMonitoringLoop - :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b + :: PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b -> m () peerMonitoringLoop pch@PeerConnectionHandle { pchConnectionId, pchPeerStatus, pchAppHandles } = do -- A first-to-finish synchronisation on all the bundles; As a result @@ -727,7 +727,7 @@ withPeerStateActions PeerStateActionsArguments { -> IsBigLedgerPeer -> DiffusionMode -> peerAddr - -> m (PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b) + -> m (PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b) establishPeerConnection jobPool isBigLedgerPeer diffusionMode remotePeerAddr = -- Protect consistency of the peer state with 'bracketOnError' if -- opening a connection fails. @@ -820,7 +820,7 @@ withPeerStateActions PeerStateActionsArguments { throwIO err where mkAwaitVars :: OuroborosBundle muxMode (ExpandedInitiatorContext peerAddr m) - responderCtx ByteString m a b + responderCtx networkState ByteString m a b -> STM m (TemperatureBundle (StrictTVar m (Map MiniProtocolNum @@ -828,7 +828,7 @@ withPeerStateActions PeerStateActionsArguments { mkAwaitVars = traverse f where f :: [MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m) - responderCtx ByteString m a b] + responderCtx networkState ByteString m a b] -> STM m (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))) @@ -849,14 +849,14 @@ withPeerStateActions PeerStateActionsArguments { -- It returns 'Nothing' only if all mini-protocols are either not running -- or still executing. -- - monitorPeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b + monitorPeerConnection :: PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b -> STM m (PeerStatus, Maybe RepromoteDelay) monitorPeerConnection PeerConnectionHandle { pchPeerStatus, pchAppHandles } = p <$> readTVar pchPeerStatus <*> (g <$> traverse f pchAppHandles) `orElse` throwSTM MonitorPeerConnectionBlocked where - f :: ApplicationHandle muxMode responderCtx peerAddr ByteString m a b + f :: ApplicationHandle muxMode responderCtx networkState peerAddr ByteString m a b -> STM m (Map MiniProtocolNum (Maybe (HasReturned a))) -- do not block when a mini-protocol is still running, otherwise -- outbound governor @@ -894,7 +894,7 @@ withPeerStateActions PeerStateActionsArguments { -- of time timeouts should be implemented here in the same way it is in -- establishPeerConnection and deactivatePeerConnection. activatePeerConnection :: IsBigLedgerPeer - -> PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b + -> PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b -> m () activatePeerConnection isBigLedgerPeer @@ -932,7 +932,7 @@ withPeerStateActions PeerStateActionsArguments { -- Take a hot peer and demote it to a warm one. - deactivatePeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b -> m () + deactivatePeerConnection :: PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b -> m () deactivatePeerConnection PeerConnectionHandle { pchConnectionId, @@ -1003,7 +1003,7 @@ withPeerStateActions PeerStateActionsArguments { throwIO $ ColdDeactivationException pchConnectionId - closePeerConnection :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b + closePeerConnection :: PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b -> m Bool closePeerConnection PeerConnectionHandle { @@ -1072,15 +1072,15 @@ withPeerStateActions PeerStateActionsArguments { -- | Smart constructor for 'ApplicationHandle'. -- mkApplicationHandleBundle - :: forall (muxMode :: Mux.Mode) responderCtx peerAddr bytes m a b. + :: forall (muxMode :: Mux.Mode) responderCtx networkState peerAddr bytes m a b. OuroborosBundle muxMode (ExpandedInitiatorContext peerAddr m) - responderCtx bytes m a b + responderCtx networkState bytes m a b -- ^ mux application -> TemperatureBundle (StrictTVar m ControlMessage) -- ^ 'ControlMessage' bundle -> TemperatureBundle (StrictTVar m (Map MiniProtocolNum (STM m (HasReturned a)))) -- ^ await for application termination - -> TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b) + -> TemperatureBundle (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b) mkApplicationHandleBundle muxBundle controlMessageBundle awaitVarsBundle = TemperatureBundle (mkApplication SingHot) @@ -1088,7 +1088,7 @@ mkApplicationHandleBundle muxBundle controlMessageBundle awaitVarsBundle = (mkApplication SingEstablished) where mkApplication :: SingProtocolTemperature pt - -> WithProtocolTemperature pt (ApplicationHandle muxMode responderCtx peerAddr bytes m a b) + -> WithProtocolTemperature pt (ApplicationHandle muxMode responderCtx networkState peerAddr bytes m a b) mkApplication tok = let app = ApplicationHandle { @@ -1106,7 +1106,7 @@ mkApplicationHandleBundle muxBundle controlMessageBundle awaitVarsBundle = -- protocol bundle indicated by the type of the first argument. -- startProtocols :: forall (muxMode :: Mux.Mode) (pt :: ProtocolTemperature) - responderCtx peerAddr versionData m a b. + responderCtx networkState peerAddr versionData m a b. ( Alternative (STM m) , MonadAsync m , MonadCatch m @@ -1115,7 +1115,7 @@ startProtocols :: forall (muxMode :: Mux.Mode) (pt :: ProtocolTemperature) ) => SingProtocolTemperature pt -> IsBigLedgerPeer - -> PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b + -> PeerConnectionHandle muxMode responderCtx networkState peerAddr versionData ByteString m a b -> m () startProtocols tok isBigLedgerPeer connHandle@PeerConnectionHandle { pchMux, pchAppHandles } = do let ptcls = getProtocols tok pchAppHandles @@ -1130,7 +1130,7 @@ startProtocols tok isBigLedgerPeer connHandle@PeerConnectionHandle { pchMux, pch . Map.fromList runInitiator :: MiniProtocol muxMode (ExpandedInitiatorContext peerAddr m) - responderCtx ByteString m a b + responderCtx networkState ByteString m a b -> m (STM m (Either SomeException a)) runInitiator MiniProtocol { miniProtocolNum, diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index ca5ed1cbc1..b1bdffe00e 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -172,6 +172,8 @@ data Arguments extraChurnArgs extraFlags m = Arguments -- type ResolverException = SomeException +type NetworkState = () + run :: forall extraState extraDebugState extraAPI extraPeers extraFlags extraChurnArgs extraCounters exception resolver resolverError m. @@ -217,7 +219,7 @@ run :: forall extraState extraDebugState extraAPI extraCounters NtNAddr (PeerConnectionHandle - muxMode responderCtx NtNAddr ntnVersionData bytes m a b) + muxMode responderCtx NetworkState NtNAddr ntnVersionData bytes m a b) exception m) -> (forall muxMode responderCtx ntnVersionData bytes a b. @@ -227,7 +229,7 @@ run :: forall extraState extraDebugState extraAPI extraPeers NtNAddr (PeerConnectionHandle - muxMode responderCtx NtNAddr ntnVersionData bytes m a b) + muxMode responderCtx NetworkState NtNAddr ntnVersionData bytes m a b) -> extraCounters) -> (Map NtNAddr PeerAdvertise -> extraPeers) -> ( PeerActionsDNS NtNAddr resolver resolverError m diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index 9473b1ef81..f38ed1e5c2 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -101,6 +101,9 @@ import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.Diffusion.Node.Kernel +type NetworkState = () + + -- | Protocol codecs. -- data Codecs addr header block m = Codecs @@ -295,12 +298,12 @@ applications debugTracer nodeKernel where initiatorApp :: PSTypes.PeerSharing - -> OuroborosBundleWithExpandedCtx Mx.InitiatorMode NtNAddr ByteString m () Void + -> OuroborosBundleWithExpandedCtx Mx.InitiatorMode NetworkState NtNAddr ByteString m () Void -- initiator mode will never run a peer sharing responder side initiatorApp peerSharing = fmap f <$> initiatorAndResponderApp peerSharing where - f :: MiniProtocolWithExpandedCtx Mx.InitiatorResponderMode NtNAddr ByteString m () () - -> MiniProtocolWithExpandedCtx Mx.InitiatorMode NtNAddr ByteString m () Void + f :: MiniProtocolWithExpandedCtx Mx.InitiatorResponderMode NetworkState NtNAddr ByteString m () () + -> MiniProtocolWithExpandedCtx Mx.InitiatorMode NetworkState NtNAddr ByteString m () Void f MiniProtocol { miniProtocolNum , miniProtocolLimits , miniProtocolRun } = @@ -315,7 +318,7 @@ applications debugTracer nodeKernel initiatorAndResponderApp :: PSTypes.PeerSharing - -> OuroborosBundleWithExpandedCtx Mx.InitiatorResponderMode NtNAddr ByteString m () () + -> OuroborosBundleWithExpandedCtx Mx.InitiatorResponderMode NetworkState NtNAddr ByteString m () () initiatorAndResponderApp peerSharing = TemperatureBundle { withHot = WithHot [ MiniProtocol @@ -376,7 +379,7 @@ applications debugTracer nodeKernel localResponderApp :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode NtCAddr ByteString m Void () + Mx.ResponderMode NetworkState NtCAddr ByteString m Void () localResponderApp = OuroborosApplication [] chainSyncInitiator diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs index a48556b708..20d26fd6ce 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs @@ -66,9 +66,8 @@ activeTracer = nullTracer _sayTracer :: MonadSay m => Tracer m String _sayTracer = Tracer say - -testProtocols :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b - -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b +testProtocols :: RunMiniProtocolWithMinimalCtx appType () addr bytes m a b + -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b testProtocols chainSync = OuroborosApplication [ MiniProtocol { @@ -208,6 +207,8 @@ demo chain0 updates delay = do case miniProtocolRun of ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] + ResponderProtocolOnlyWithState {} -> + error "query network state is not supported" ] withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps From 139dea1c39de52b4697b237fbf5456bfb1cb454c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 27 Dec 2024 09:28:08 +0100 Subject: [PATCH 05/12] outbound-governor: CapturePublicState Instead of writing `PublicPeerSelectionState` on each outbound governor loop iteration, provide a request-response API through a `StrictTMVar` which is monitored by the outbound governor. Note that `PublicPeerSelectionState` is a lazy record written through `StrictTMVar` via a lazy `Maybe` like type (and thus it is not evaluated to WHNF when written to the shared variable). It is up to the API user to evaluate what it needs. --- .../src/Ouroboros/Network/Diffusion.hs | 8 +-- .../src/Ouroboros/Network/Diffusion/Types.hs | 4 +- .../Network/PeerSelection/Governor.hs | 17 +++--- .../Network/PeerSelection/Governor/Monitor.hs | 17 ++++++ .../Network/PeerSelection/Governor/Types.hs | 55 ++++++++++++++++++- .../src/Ouroboros/Network/PeerSharing.hs | 31 ++++++----- .../Test/Ouroboros/Network/Diffusion/Node.hs | 21 +++---- .../Network/Diffusion/Node/Kernel.hs | 11 ++-- .../Network/Diffusion/Testnet/Cardano.hs | 2 + .../Test/Ouroboros/Network/PeerSelection.hs | 6 +- .../PeerSelection/Cardano/MockEnvironment.hs | 5 +- 11 files changed, 124 insertions(+), 53 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 7ee614916a..7e3ca21ae3 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -210,7 +210,7 @@ runM Interfaces , daLocalAddress , daAcceptedConnectionsLimit , daMode = diffusionMode - , daPublicPeerSelectionVar + , daCapturePublicStateVar , daPeerSelectionTargets , daReadLocalRootPeers , daReadPublicRootPeers @@ -673,9 +673,9 @@ runM Interfaces peerSelectionPolicy PeerSelectionInterfaces { countersVar, - publicStateVar = daPublicPeerSelectionVar, - debugStateVar = dbgVar, - readUseLedgerPeers = daReadUseLedgerPeers + capturePublicStateVar = daCapturePublicStateVar, + debugStateVar = dbgVar, + readUseLedgerPeers = daReadUseLedgerPeers } diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs index 56429e5e27..2d1d06749d 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -73,7 +73,7 @@ import Ouroboros.Network.NodeToClient qualified as NodeToClient import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, DiffusionMode) import Ouroboros.Network.NodeToNode qualified as NodeToNode import Ouroboros.Network.PeerSelection as PeerSelection -import Ouroboros.Network.PeerSelection.Governor.Types +import Ouroboros.Network.PeerSelection.Governor.Types as Governor import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers @@ -282,7 +282,7 @@ data Arguments extraState extraDebugState extraFlags extraPeers -- It is created outside of diffusion, since it is needed to create some -- apps (e.g. peer sharing). -- - , daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState ntnAddr) + , daCapturePublicStateVar :: Governor.CapturePublicStateVar ntnAddr m -- | selection targets for the peer governor -- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs index 5f3fa88432..404c6b6b5e 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs @@ -23,20 +23,24 @@ module Ouroboros.Network.PeerSelection.Governor , PeerSelectionActions (..) , PeerSelectionInterfaces (..) , PeerStateActions (..) - , PeerSelectionGovernorArgs (..) , TracePeerSelection (..) , ChurnAction (..) , DebugPeerSelection (..) , AssociationMode (..) , readAssociationMode , DebugPeerSelectionState (..) + , PeerSelectionGovernorArgs (..) , peerSelectionGovernor + -- * PublicPeerSelectionState API + , CapturePublicStateVar + , newCapturePublicStateVar + , PublicPeerSelectionState (..) + , requestPublicState -- * Internals exported for testing , assertPeerSelectionState , sanePeerSelectionTargets , establishedPeersStatus , PeerSelectionState (..) - , PublicPeerSelectionState (..) , makePublicPeerSelectionStateVar , PeerSelectionView (..) , PeerSelectionCounters @@ -567,7 +571,7 @@ peerSelectionGovernorLoop tracer policy interfaces@PeerSelectionInterfaces { countersVar, - publicStateVar, + capturePublicStateVar, debugStateVar } jobPool @@ -578,10 +582,6 @@ peerSelectionGovernorLoop tracer -> Time -> m Void loop !st !dbgUpdateAt = assertPeerSelectionState extraPeersToSet invariantExtraPeers st $ do - -- Update public state using 'toPublicState' to compute available peers - -- to share for peer sharing - atomically $ writeTVar publicStateVar (toPublicState st) - blockedAt <- getMonotonicTime -- | If there's something utterly wrong with the PeerSelectionState such @@ -664,8 +664,9 @@ peerSelectionGovernorLoop tracer -- All the alternative potentially-blocking decisions. -- Make sure preBlocking set is in the right place - preBlocking policy actions st + preBlocking policy actions st + <> Monitor.monitorCapturePublicStateVar capturePublicStateVar st <> Monitor.connections actions st <> Monitor.jobs jobPool st -- This job monitors for changes in big ledger peer snapshot file (eg. reload) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index 1c4c954861..beb529ecbd 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.PeerSelection.Governor.Monitor , connections , localRoots , ledgerPeerSnapshotChange + , monitorCapturePublicStateVar ) where import Data.Map.Strict (Map) @@ -465,3 +466,19 @@ ledgerPeerSnapshotChange extraStateChange ledgerPeerSnapshot = ledgerPeerSnapshot' } } + + +monitorCapturePublicStateVar + :: MonadSTM m + => CapturePublicStateVar peeraddr m + -> PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn + -> Guarded (STM m) (TimedDecision m extraState extraDebugState extraFlags extraPeers peeraddr peerconn) +monitorCapturePublicStateVar v st = Guarded Nothing $ do + let pst = toPublicState st + handlePublicStateRequest v pst + return $ \_ -> + Decision { + decisionTrace = [TracePublicPeerSelectionState pst], + decisionJobs = [], + decisionState = st + } diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index 3830e61f78..940c839090 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -117,6 +117,12 @@ module Ouroboros.Network.PeerSelection.Governor.Types -- * Peer Sharing Auxiliary data type , PeerSharingResult (..) + -- * Capture public state + , CapturePublicState (..) + , CapturePublicStateVar + , newCapturePublicStateVar + , requestPublicState + , handlePublicStateRequest -- * Traces , TracePeerSelection (..) , ChurnAction (..) @@ -418,9 +424,10 @@ data PeerSelectionInterfaces extraState extraFlags extraPeers extraCounters peer -- countersVar :: StrictTVar m (PeerSelectionCounters extraCounters), - -- | PublicPeerSelectionState var. + -- | An interface to request / receive `PublicPeerSelectionState` -- - publicStateVar :: StrictTVar m (PublicPeerSelectionState peeraddr), + capturePublicStateVar + :: CapturePublicStateVar peeraddr m, -- | PeerSelectionState shared for debugging purposes (to support SIGUSR1 -- debug event tracing) @@ -1827,6 +1834,8 @@ data TracePeerSelection extraDebugState extraFlags extraPeers peeraddr = | TraceUseBootstrapPeersChanged UseBootstrapPeers | TraceVerifyPeerSnapshot Bool + | TracePublicPeerSelectionState (PublicPeerSelectionState peeraddr) + -- -- Critical Failures -- @@ -1877,3 +1886,45 @@ deriving instance ( Show extraState , Ord peeraddr , Show peeraddr ) => Show (DebugPeerSelection extraState extraFlags extraPeers peeraddr) + +-- | Request / response for capturing public state. Internal. +-- +data CapturePublicState peeraddr + = RequestState + | CapturedState (PublicPeerSelectionState peeraddr) + +newtype CapturePublicStateVar peeraddr m = + CapturePublicStateVar (StrictTMVar m (CapturePublicState peeraddr)) + +newCapturePublicStateVar :: MonadSTM m + => m (CapturePublicStateVar peeraddr m) +newCapturePublicStateVar = CapturePublicStateVar <$> newEmptyTMVarIO + +-- | Put a request in `CaptureStateVar`. +-- +requestPublicState :: MonadSTM m + => CapturePublicStateVar peeraddr m + -> m (PublicPeerSelectionState peeraddr) +requestPublicState (CapturePublicStateVar v) = do + -- `putTMVar` and `writePublicState` guard that there's only one request in + -- flight, since it is `requestPublicState` that empties the + -- `CaptureStateVar`. + atomically $ putTMVar v RequestState + atomically $ do + a <- takeTMVar v + case a of + RequestState -> retry -- request in progress + CapturedState ps -> return ps + +-- | Block for a `RequestState`, then write public state back. +-- +handlePublicStateRequest + :: MonadSTM m + => CapturePublicStateVar peeraddr m + -> PublicPeerSelectionState peeraddr + -> STM m () +handlePublicStateRequest (CapturePublicStateVar v) st = do + a <- readTMVar v + case a of + RequestState -> writeTMVar v (CapturedState st) + (CapturedState _) -> retry diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs b/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs index 3d789585fc..908cde931b 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs @@ -32,8 +32,9 @@ import Data.Map.Strict qualified as Map import Data.Monoid.Synchronisation (FirstToFinish (..), runFirstToFinish) import Data.Set qualified as Set import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) -import Ouroboros.Network.PeerSelection.Governor.Types (PublicPeerSelectionState, +import Ouroboros.Network.PeerSelection.Governor.Types (CapturePublicStateVar, availableToShare) +import Ouroboros.Network.PeerSelection.Governor.Types qualified as Governor import Ouroboros.Network.Protocol.PeerSharing.Client (PeerSharingClient (..)) import Ouroboros.Network.Protocol.PeerSharing.Server (PeerSharingServer (..)) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..), @@ -152,13 +153,13 @@ peerSharingServer peerSharingAPI = -- | PeerSharingAPI needed to compute the peers to be shared. -- data PeerSharingAPI addr s m = - PeerSharingAPI { psPublicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addr) - , psGenVar :: StrictTVar m s - , psReSaltAtVar :: StrictTVar m Time - , psPolicyPeerShareStickyTime :: !DiffTime + PeerSharingAPI { psCapturePublicStateVar :: CapturePublicStateVar addr m + , psGenVar :: StrictTVar m s + , psReSaltAtVar :: StrictTVar m Time + , psPolicyPeerShareStickyTime :: !DiffTime -- ^ Amount of time between changes to the salt used to pick peers to -- gossip about. - , psPolicyPeerShareMaxPeers :: !PeerSharingAmount + , psPolicyPeerShareMaxPeers :: !PeerSharingAmount -- ^ Maximum number of peers to respond with in a single request } @@ -176,23 +177,23 @@ ps_POLICY_PEER_SHARE_MAX_PEERS = 10 -- | Create a new PeerSharingAPI -- newPeerSharingAPI :: MonadSTM m - => StrictTVar m (PublicPeerSelectionState addr) + => CapturePublicStateVar addr m -> s -> DiffTime -> PeerSharingAmount -> m (PeerSharingAPI addr s m) -newPeerSharingAPI publicPeerSelectionStateVar +newPeerSharingAPI capturePublicStateVar rng policyPeerShareStickyTime policyPeerShareMaxPeers = do genVar <- newTVarIO rng reSaltAtVar <- newTVarIO (Time 0) return $ - PeerSharingAPI { psPublicPeerSelectionStateVar = publicPeerSelectionStateVar, - psGenVar = genVar, - psReSaltAtVar = reSaltAtVar, - psPolicyPeerShareStickyTime = policyPeerShareStickyTime, - psPolicyPeerShareMaxPeers = policyPeerShareMaxPeers + PeerSharingAPI { psCapturePublicStateVar = capturePublicStateVar, + psGenVar = genVar, + psReSaltAtVar = reSaltAtVar, + psPolicyPeerShareStickyTime = policyPeerShareStickyTime, + psPolicyPeerShareMaxPeers = policyPeerShareMaxPeers } -- | Select a random subset of the known peers that are available to publish through peersharing. @@ -208,14 +209,14 @@ computePeerSharingPeers :: ( MonadSTM m => PeerSharingAPI ntnAddr s m -> PeerSharingAmount -> m [ntnAddr] -computePeerSharingPeers PeerSharingAPI{ psPublicPeerSelectionStateVar, +computePeerSharingPeers PeerSharingAPI{ psCapturePublicStateVar, psPolicyPeerShareStickyTime, psPolicyPeerShareMaxPeers, psReSaltAtVar, psGenVar } amount = do now <- getMonotonicTime - publicState <- readTVarIO psPublicPeerSelectionStateVar + publicState <- Governor.requestPublicState psCapturePublicStateVar salt <- atomically $ do reSaltAt <- readTVar psReSaltAtVar if reSaltAt <= now diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs index b1bdffe00e..09c51948c7 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -27,7 +27,7 @@ module Test.Ouroboros.Network.Diffusion.Node , AcceptedConnectionsLimit (..) , DiffusionMode (..) , PeerAdvertise (..) - , PeerSelectionTargets (..) + , Governor.PeerSelectionTargets (..) -- * configuration constants , config_REPROMOTE_DELAY -- * re-exports @@ -89,10 +89,7 @@ import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..), import Ouroboros.Network.Mock.ProducerState (ChainProducerState (..)) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.Churn (PeerChurnArgs) -import Ouroboros.Network.PeerSelection.Governor (PeerSelectionState (..), - PeerSelectionTargets (..), PublicPeerSelectionState (..)) -import Ouroboros.Network.PeerSelection.Governor.Types - (PeerSelectionGovernorArgs) +import Ouroboros.Network.PeerSelection.Governor qualified as Governor import Ouroboros.Network.PeerSelection.LedgerPeers (NumberOfPeers) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeersConsensusInterface, LedgerPeersKind, UseLedgerPeers) @@ -152,7 +149,7 @@ data Arguments extraChurnArgs extraFlags m = Arguments , aShouldChainSyncExit :: BlockHeader -> m Bool , aChainSyncEarlyExit :: Bool - , aPeerTargets :: PeerSelectionTargets + , aPeerTargets :: Governor.PeerSelectionTargets , aReadLocalRootPeers :: STM m [( HotValency , WarmValency , Map RelayAccessPoint (LocalRootConfig extraFlags))] @@ -210,7 +207,7 @@ run :: forall extraState extraDebugState extraAPI -> extraCounters -> PublicExtraPeersAPI extraPeers NtNAddr -> (forall muxMode responderCtx ntnVersionData bytes a b . - PeerSelectionGovernorArgs + Governor.PeerSelectionGovernorArgs extraState extraDebugState extraFlags @@ -223,7 +220,7 @@ run :: forall extraState extraDebugState extraAPI exception m) -> (forall muxMode responderCtx ntnVersionData bytes a b. - PeerSelectionState + Governor.PeerSelectionState extraState extraFlags extraPeers @@ -331,7 +328,7 @@ run blockGeneratorArgs limits ni na withAsync (Diff.runM interfaces tracers - (mkArgs (nkPublicPeerSelectionVar nodeKernel)) + (mkArgs (nkCapturePublicStateVar nodeKernel)) apps) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> @@ -438,21 +435,21 @@ run blockGeneratorArgs limits ni na decodeData _ (CBOR.TList [CBOR.TBool True, CBOR.TInt a]) = NtNVersionData InitiatorAndResponderDiffusionMode <$> (toPeerSharing a) decodeData _ _ = Left (Text.pack "unversionedDataCodec: unexpected term") - mkArgs :: StrictTVar m (PublicPeerSelectionState NtNAddr) + mkArgs :: Governor.CapturePublicStateVar NtNAddr m -> Diff.Arguments extraState extraDebugState extraFlags extraPeers extraAPI extraChurnArgs extraCounters exception resolver resolverError m (NtNFD m) NtNAddr (NtCFD m) NtCAddr - mkArgs daPublicPeerSelectionVar = Diff.Arguments + mkArgs daCapturePublicStateVar = Diff.Arguments { Diff.daIPv4Address = Right <$> (ntnToIPv4 . aIPAddress) na , Diff.daIPv6Address = Right <$> (ntnToIPv6 . aIPAddress) na , Diff.daLocalAddress = Nothing , Diff.daAcceptedConnectionsLimit = aAcceptedLimits na , Diff.daMode = aDiffusionMode na - , Diff.daPublicPeerSelectionVar + , Diff.daCapturePublicStateVar , Diff.daPeerSelectionTargets = aPeerTargets na , Diff.daReadLocalRootPeers = aReadLocalRootPeers na , Diff.daReadPublicRootPeers = aReadPublicRootPeers na diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs index e0273cf5be..8b3d8ef224 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -69,8 +69,7 @@ import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.NodeToNode () import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection (PeerSharing, RelayAccessPoint (..)) -import Ouroboros.Network.PeerSelection.Governor (PublicPeerSelectionState, - makePublicPeerSelectionStateVar) +import Ouroboros.Network.PeerSelection.Governor qualified as Governor import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..), newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) @@ -280,23 +279,23 @@ data NodeKernel header block s m = NodeKernel { nkPeerSharingAPI :: PeerSharingAPI NtNAddr s m, - nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr) + nkCapturePublicStateVar :: Governor.CapturePublicStateVar NtNAddr m } newNodeKernel :: MonadSTM m => s -> m (NodeKernel header block s m) newNodeKernel rng = do - publicStateVar <- makePublicPeerSelectionStateVar + capturePublicStateVar <- Governor.newCapturePublicStateVar NodeKernel <$> newTVarIO Map.empty <*> newTVarIO (ChainProducerState Chain.Genesis Map.empty 0) <*> newFetchClientRegistry <*> newPeerSharingRegistry <*> ChainDB.newChainDB - <*> newPeerSharingAPI publicStateVar rng + <*> newPeerSharingAPI capturePublicStateVar rng ps_POLICY_PEER_SHARE_STICKY_TIME ps_POLICY_PEER_SHARE_MAX_PEERS - <*> pure publicStateVar + <*> pure capturePublicStateVar -- | Register a new upstream chain-sync client. -- diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index 4327cdecad..78f0a3f3ef 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -1509,6 +1509,8 @@ prop_peer_selection_trace_coverage defaultBearerInfo diffScript = show a peerSelectionTraceMap (TraceVerifyPeerSnapshot result) = "TraceVerifyPeerSnapshot " <> show result + peerSelectionTraceMap TracePublicPeerSelectionState {} = + "TracePublicPeerSelectionState" eventsSeenNames = map peerSelectionTraceMap events -- TODO: Add checkCoverage here diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs index aaf583506c..6e6c5244a7 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs @@ -972,6 +972,7 @@ traceNum TraceDebugState {} = 54 traceNum TraceChurnAction {} = 55 traceNum TraceChurnTimeout {} = 56 traceNum TraceVerifyPeerSnapshot {} = 57 +traceNum TracePublicPeerSelectionState {} = 58 allTraceNames :: Map Int String allTraceNames = @@ -1034,6 +1035,7 @@ allTraceNames = , (55, "TraceChurnAction") , (56, "TraceChurnTimeout") , (57, "TraceVerifyPeerSnapshot") + , (58, "TracePublicPeerSelectionState") ] @@ -4002,12 +4004,12 @@ _governorFindingPublicRoots :: Int -> IO Void _governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrapPeers readLedgerStateJudgement peerSharing olocVar consensusMode = do countersVar <- newTVarIO (emptyPeerSelectionCounters ExtraSizes.empty) - publicStateVar <- makePublicPeerSelectionStateVar + capturePublicStateVar <- Governor.newCapturePublicStateVar debugStateVar <- newTVarIO $ emptyPeerSelectionState (mkStdGen 42) (ExtraState.empty consensusMode (NumberOfBigLedgerPeers 0)) ExtraPeers.empty dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore let interfaces = PeerSelectionInterfaces { countersVar, - publicStateVar, + capturePublicStateVar, debugStateVar, readUseLedgerPeers = return DontUseLedgerPeers } diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/Cardano/MockEnvironment.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/Cardano/MockEnvironment.hs index 7e2b4076d0..b714efea03 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/Cardano/MockEnvironment.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/Cardano/MockEnvironment.hs @@ -242,7 +242,7 @@ governorAction mockEnv@GovernorMockEnvironment { targets = Script targets', ledgerStateJudgement = Script ledgerStateJudgement', seed = TestSeed seed'} = do - publicStateVar <- makePublicPeerSelectionStateVar + capturePublicStateVar <- Governor.newCapturePublicStateVar lpVar <- playTimedScript (contramap TraceEnvUseLedgerPeers tracerMockEnv) (useLedgerPeers mockEnv) usbVar <- playTimedScript (contramap TraceEnvSetUseBootstrapPeers tracerMockEnv) @@ -289,7 +289,7 @@ governorAction mockEnv@GovernorMockEnvironment { let interfaces = PeerSelectionInterfaces { countersVar, - publicStateVar, + capturePublicStateVar, debugStateVar, readUseLedgerPeers = (readTVar lpVar) } @@ -811,6 +811,7 @@ tracerTracePeerSelection = contramap f tracerTestTraceEvent f a@(TraceChurnAction !_ !_ !_) = GovernorEvent a f a@(TraceChurnTimeout !_ !_ !_) = GovernorEvent a f a@(TraceVerifyPeerSnapshot !_) = GovernorEvent a + f a@(TracePublicPeerSelectionState !_) = GovernorEvent a tracerDebugPeerSelection :: Tracer (IOSim s) (DebugPeerSelection Cardano.ExtraState PeerTrustable (Cardano.ExtraPeers PeerAddr) PeerAddr) tracerDebugPeerSelection = GovernorDebug `contramap` tracerTestTraceEvent From c5e9dec66742e295900877d89bde445975d88901 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 15 Nov 2024 13:45:41 +0100 Subject: [PATCH 06/12] ouroboros-network-api: public NetworkState It includes data from connection-manager and outbound/inbound governors. --- .../ouroboros-network-api.cabal | 4 + .../src/Ouroboros/Network/ConnectionId.hs | 0 .../Network/ConnectionManager/Public.hs | 60 +++ .../src/Ouroboros/Network/PublicState.hs | 362 ++++++++++++++++++ .../ouroboros-network-framework.cabal | 1 - .../Network/ConnectionManager/ConnMap.hs | 8 + .../Network/ConnectionManager/State.hs | 13 + .../Network/ConnectionManager/Types.hs | 56 +-- .../Network/PeerSelection/Governor/Types.hs | 18 + 9 files changed, 466 insertions(+), 56 deletions(-) rename {ouroboros-network-framework => ouroboros-network-api}/src/Ouroboros/Network/ConnectionId.hs (100%) create mode 100644 ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs create mode 100644 ouroboros-network-api/src/Ouroboros/Network/PublicState.hs diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index 961ba3950c..f51409facf 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -33,6 +33,8 @@ library Ouroboros.Network.Block Ouroboros.Network.BlockFetch.ConsensusInterface Ouroboros.Network.CodecCBORTerm + Ouroboros.Network.ConnectionId + Ouroboros.Network.ConnectionManager.Public Ouroboros.Network.ControlMessage Ouroboros.Network.Handshake Ouroboros.Network.Handshake.Acceptable @@ -49,6 +51,7 @@ library Ouroboros.Network.PeerSelection.RelayAccessPoint Ouroboros.Network.Point Ouroboros.Network.Protocol.Limits + Ouroboros.Network.PublicState Ouroboros.Network.SizeInBytes Ouroboros.Network.Util.ShowProxy @@ -67,6 +70,7 @@ library contra-tracer, deepseq, dns, + hashable, io-classes ^>=1.5.0, iproute ^>=1.7.15, measures, diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionId.hs b/ouroboros-network-api/src/Ouroboros/Network/ConnectionId.hs similarity index 100% rename from ouroboros-network-framework/src/Ouroboros/Network/ConnectionId.hs rename to ouroboros-network-api/src/Ouroboros/Network/ConnectionId.hs diff --git a/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs b/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs new file mode 100644 index 0000000000..1f5b4fd06d --- /dev/null +++ b/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs @@ -0,0 +1,60 @@ +module Ouroboros.Network.ConnectionManager.Public + ( Provenance (..) + , DataFlow (..) + , TimeoutExpired (..) + , AbstractState (..) + ) where + + +-- | Each connection is is either initiated locally (outbound) or by a remote +-- peer (inbound). +-- +data Provenance = + -- | An inbound connection: one that was initiated by a remote peer. + -- + Inbound + + -- | An outbound connection: one that was initiated by us. + -- + | Outbound + deriving (Eq, Ord, Show) + + +-- | Each connection negotiates if it is uni- or bi-directional. 'DataFlow' +-- is a life time property of a connection, once negotiated it never changes. +-- +-- NOTE: This type is isomorphic to `DiffusionMode` for `node-to-node` +-- connections (see `Ouroboros.Network.Diffusion.P2P.ntnDataFlow`), but it isn't +-- for `node-to-client` connections (see +-- `Ouroboros.Network.Diffusion.P2P.ntcDataFlow). +-- +data DataFlow + = Unidirectional + | Duplex + deriving (Eq, Ord, Show) + + +-- | Boolean like type which indicates if the timeout on 'OutboundStateDuplex' +-- has expired. +data TimeoutExpired = Expired | Ticking + deriving (Eq, Ord, Show) + + +-- | Useful for tracing and error messages. +-- +data AbstractState = + -- | Unknown connection. This state indicates the connection manager + -- removed this connection from its state. + UnknownConnectionSt + | ReservedOutboundSt + | UnnegotiatedSt !Provenance + | InboundIdleSt !DataFlow + | InboundSt !DataFlow + | OutboundUniSt + | OutboundDupSt !TimeoutExpired + | OutboundIdleSt !DataFlow + | DuplexSt + | WaitRemoteIdleSt + | TerminatingSt + | TerminatedSt + deriving (Eq, Ord, Show) diff --git a/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs b/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs new file mode 100644 index 0000000000..1c145e6bc6 --- /dev/null +++ b/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Public state of P2P network which can be queryied using `cardano-cli`. +-- +module Ouroboros.Network.PublicState + ( -- * Network state + NetworkState (..) + , mapNetworkStateMonotonic + , ConnectionManagerState (..) + , InboundState (..) + , mapInboundStateMonotonic + , emptyInboundState + , OutboundState (..) + , mapOutboundStateMonotonic + -- * Codecs + , encodeNetworkState + , decodeNetworkState + -- * Re-exports + , RemoteAddressEncoding (..) + ) where + +import Codec.CBOR.Decoding +import Codec.CBOR.Encoding +import Codec.Serialise (Serialise) +import Codec.Serialise.Class (decode, encode) +import Control.Monad (replicateM) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set + +import Ouroboros.Network.ConnectionId +import Ouroboros.Network.ConnectionManager.Public +import Ouroboros.Network.PeerSelection.PeerSharing.Codec + (RemoteAddressEncoding (..)) + + +data ConnectionManagerState peeraddr = ConnectionManagerState { + connectionMap :: Map (ConnectionId peeraddr) AbstractState, + -- ^ map of connections, without outbound connections in + -- `ReservedOutboundSt` state. + + registeredOutboundConnections :: Set peeraddr + -- ^ set of outbound connections in `ReserverdOutboundSt` state. + } + deriving (Eq, Show) + +-- | Map 'ConnectionManagerState' +-- +mapConnectionManagerStateMonotonic + :: (peeraddr -> peeraddr') + -- ^ a monotonic map + -> ConnectionManagerState peeraddr + -> ConnectionManagerState peeraddr' +mapConnectionManagerStateMonotonic + fn + ConnectionManagerState { + connectionMap, + registeredOutboundConnections + } = + ConnectionManagerState { + connectionMap = Map.mapKeysMonotonic (fmap fn) connectionMap, + registeredOutboundConnections = Set.mapMonotonic fn registeredOutboundConnections + } + + +data InboundState peeraddr = InboundState { + remoteHotSet :: !(Set (ConnectionId peeraddr)), + remoteWarmSet :: !(Set (ConnectionId peeraddr)), + remoteColdSet :: !(Set (ConnectionId peeraddr)), + remoteIdleSet :: !(Set (ConnectionId peeraddr)) + } + deriving (Eq, Show) + +mapInboundStateMonotonic + :: (peeraddr -> peeraddr') + -- ^ a monotonic map + -> InboundState peeraddr + -> InboundState peeraddr' +mapInboundStateMonotonic + fn + InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + } = + InboundState { + remoteHotSet = Set.mapMonotonic (fmap fn) remoteHotSet, + remoteWarmSet = Set.mapMonotonic (fmap fn) remoteWarmSet, + remoteColdSet = Set.mapMonotonic (fmap fn) remoteColdSet, + remoteIdleSet = Set.mapMonotonic (fmap fn) remoteIdleSet + } + +emptyInboundState :: InboundState peeraddr +emptyInboundState = InboundState { + remoteHotSet = Set.empty, + remoteWarmSet = Set.empty, + remoteColdSet = Set.empty, + remoteIdleSet = Set.empty + } + +data OutboundState peeraddr = OutboundState { + coldPeers :: Set peeraddr, + warmPeers :: Set peeraddr, + hotPeers :: Set peeraddr + } + deriving (Eq, Show) + +mapOutboundStateMonotonic + :: (peeraddr -> peeraddr') + -- ^ a monotonic map + -> OutboundState peeraddr + -> OutboundState peeraddr' +mapOutboundStateMonotonic + fn + OutboundState { + coldPeers, + warmPeers, + hotPeers + } = + OutboundState { + coldPeers = Set.mapMonotonic fn coldPeers, + warmPeers = Set.mapMonotonic fn warmPeers, + hotPeers = Set.mapMonotonic fn hotPeers + } + + + +data NetworkState peeraddr = NetworkState { + connectionManagerState :: ConnectionManagerState peeraddr, + -- TODO: + -- handshakes :: !(Map (ConnectionId peeraddr) (version, versionData)), + inboundGovernorState :: InboundState peeraddr, + outboundGovernorState :: OutboundState peeraddr + } + deriving (Eq, Show) + +mapNetworkStateMonotonic + :: (peeraddr -> peeraddr') + -- ^ a monotonic map + -> NetworkState peeraddr + -> NetworkState peeraddr' +mapNetworkStateMonotonic + fn + NetworkState { + connectionManagerState, + inboundGovernorState, + outboundGovernorState + } + = + NetworkState { + connectionManagerState = mapConnectionManagerStateMonotonic fn + connectionManagerState, + inboundGovernorState = mapInboundStateMonotonic fn + inboundGovernorState, + outboundGovernorState = mapOutboundStateMonotonic fn + outboundGovernorState + } + + +-- +-- CBOR encoding / decoding +-- + +encodeNetworkState + :: Serialise (RemoteAddressEncoding peeraddr) + => NetworkState peeraddr + -> Encoding +encodeNetworkState + NetworkState { + outboundGovernorState = OutboundState { + coldPeers, + warmPeers, + hotPeers + }, + inboundGovernorState = InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + }, + connectionManagerState = ConnectionManagerState { + connectionMap, + registeredOutboundConnections + } + } + = encodeListLen 9 + -- outbound state + <> encode (RemoteAddressEncoding `map` Set.toList coldPeers) + <> encode (RemoteAddressEncoding `map` Set.toList warmPeers) + <> encode (RemoteAddressEncoding `map` Set.toList hotPeers) + + -- inbound state + <> encode (toPair <$> Set.toList remoteHotSet) + <> encode (toPair <$> Set.toList remoteWarmSet) + <> encode (toPair <$> Set.toList remoteColdSet) + <> encode (toPair <$> Set.toList remoteIdleSet) + + -- connection manager state + <> encodeListLen (fromIntegral $ Map.size connectionMap) + <> Map.foldMapWithKey (\connId st -> encodeListLen 2 + <> encode (toPair connId) + <> encodeConnState st) + connectionMap + <> encode (RemoteAddressEncoding `map` Set.toList registeredOutboundConnections) + + where + toPair :: ConnectionId addr -> (RemoteAddressEncoding addr, RemoteAddressEncoding addr) + toPair ConnectionId { remoteAddress, localAddress } = + (RemoteAddressEncoding remoteAddress, RemoteAddressEncoding localAddress) + + encodeConnState :: AbstractState -> Encoding + encodeConnState UnknownConnectionSt = + encodeListLen 1 + <> encodeWord8 0 + encodeConnState ReservedOutboundSt = + encodeListLen 1 + <> encodeWord8 1 + encodeConnState (UnnegotiatedSt a) = + encodeListLen 2 + <> encodeWord8 2 + <> encodeProvenance a + encodeConnState (InboundIdleSt a) = + encodeListLen 2 + <> encodeWord8 3 + <> encodeDataFlow a + encodeConnState (InboundSt a) = + encodeListLen 2 + <> encodeWord8 4 + <> encodeDataFlow a + encodeConnState OutboundUniSt = + encodeListLen 1 + <> encodeWord8 5 + encodeConnState (OutboundDupSt a) = + encodeListLen 2 + <> encodeWord8 6 + <> encodeTimeoutExpired a + encodeConnState (OutboundIdleSt a) = + encodeListLen 2 + <> encodeWord8 7 + <> encodeDataFlow a + encodeConnState DuplexSt = + encodeListLen 1 + <> encodeWord8 8 + encodeConnState WaitRemoteIdleSt = + encodeListLen 1 + <> encodeWord8 9 + encodeConnState TerminatingSt = + encodeListLen 1 + <> encodeWord8 10 + encodeConnState TerminatedSt = + encodeListLen 1 + <> encodeWord8 11 + + encodeProvenance :: Provenance -> Encoding + encodeProvenance Inbound = encodeWord8 0 + encodeProvenance Outbound = encodeWord8 1 + + encodeDataFlow :: DataFlow -> Encoding + encodeDataFlow Unidirectional = encodeWord8 0 + encodeDataFlow Duplex = encodeWord8 1 + + encodeTimeoutExpired :: TimeoutExpired -> Encoding + encodeTimeoutExpired Expired = encodeWord8 0 + encodeTimeoutExpired Ticking = encodeWord8 1 + + +decodeNetworkState + :: (Serialise (RemoteAddressEncoding peeraddr), Ord peeraddr) + => Decoder s (NetworkState peeraddr) +decodeNetworkState = do + _ <- decodeListLen + -- outbound state + coldPeers <- Set.fromList . map getRemoteAddressEncoding <$> decode + warmPeers <- Set.fromList . map getRemoteAddressEncoding <$> decode + hotPeers <- Set.fromList . map getRemoteAddressEncoding <$> decode + + -- inbound state + remoteHotSet <- Set.fromList . map fromPair <$> decode + remoteWarmSet <- Set.fromList . map fromPair <$> decode + remoteColdSet <- Set.fromList . map fromPair <$> decode + remoteIdleSet <- Set.fromList . map fromPair <$> decode + + -- connection manager state + a <- decodeListLen + connectionMap + <- fmap Map.fromList $ replicateM a $ do + _ <- decodeListLen + connId <- fromPair <$> decode + st <- decodeConnState + return (connId, st) + registeredOutboundConnections + <- Set.fromList . map getRemoteAddressEncoding <$> decode + + + return NetworkState { + outboundGovernorState = OutboundState { + coldPeers, + warmPeers, + hotPeers + }, + inboundGovernorState = InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + }, + connectionManagerState = ConnectionManagerState { + connectionMap, + registeredOutboundConnections + } + } + + where + fromPair :: (RemoteAddressEncoding addr, RemoteAddressEncoding addr) -> ConnectionId addr + fromPair (RemoteAddressEncoding remoteAddress, RemoteAddressEncoding localAddress) = + ConnectionId {remoteAddress, localAddress} + + decodeProvenance :: Decoder s Provenance + decodeProvenance = do + tag <- decodeWord8 + case tag of + 0 -> return Inbound + 1 -> return Outbound + _ -> fail ("decodeProvenance: unknown tag " ++ show tag) + + decodeDataFlow :: Decoder s DataFlow + decodeDataFlow = do + tag <- decodeWord8 + case tag of + 0 -> return Unidirectional + 1 -> return Duplex + _ -> fail ("decodeDataFlow: unknown tag " ++ show tag) + + decodeTimeoutExpired :: Decoder s TimeoutExpired + decodeTimeoutExpired = do + tag <- decodeWord8 + case tag of + 0 -> return Expired + 1 -> return Ticking + _ -> fail ("decodeTimeoutExpired: unknown tag " ++ show tag) + + decodeConnState :: Decoder s AbstractState + decodeConnState = do + _ <- decodeListLen + tag <- decodeWord8 + case tag of + 0 -> return UnknownConnectionSt + 1 -> return ReservedOutboundSt + 2 -> UnnegotiatedSt <$> decodeProvenance + 3 -> InboundIdleSt <$> decodeDataFlow + 4 -> InboundSt <$> decodeDataFlow + 5 -> return OutboundUniSt + 6 -> OutboundDupSt <$> decodeTimeoutExpired + 7 -> OutboundIdleSt <$> decodeDataFlow + 8 -> return DuplexSt + 9 -> return WaitRemoteIdleSt + 10 -> return TerminatingSt + 11 -> return TerminatedSt + _ -> fail ("decodeConnState: unknown tag " ++ show tag) diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index dd22166b33..449925f490 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -28,7 +28,6 @@ library NoThunks.Class.Orphans Ouroboros.Network.Channel Ouroboros.Network.ConnectionHandler - Ouroboros.Network.ConnectionId Ouroboros.Network.ConnectionManager.ConnMap Ouroboros.Network.ConnectionManager.Core Ouroboros.Network.ConnectionManager.InformationChannel diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs index 9aaa5ff610..e1a49d190c 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/ConnMap.hs @@ -8,6 +8,7 @@ module Ouroboros.Network.ConnectionManager.ConnMap , LocalAddr (..) , toList , toMap + , unknownSet , empty , insert , insertUnknownLocalAddr @@ -25,6 +26,7 @@ import Prelude hiding (lookup) import Data.Foldable qualified as Foldable import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Set (Set) import System.Random (RandomGen, uniformR) import Ouroboros.Network.ConnectionId @@ -85,6 +87,12 @@ toMap = . getConnMap +unknownSet :: Ord peerAddr => ConnMap peerAddr a -> Set peerAddr +unknownSet = Map.keysSet + . Map.filter (UnknownLocalAddr `Map.member`) + . getConnMap + + empty :: ConnMap peerAddr a empty = ConnMap Map.empty diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs index cc6c804d03..7d5cf48754 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/State.hs @@ -11,6 +11,7 @@ module Ouroboros.Network.ConnectionManager.State ( -- * ConnectionManagerState API ConnectionManagerState , module ConnMap + , toPublic -- ** Monadic API , readConnectionStates , readAbstractStateMap @@ -37,6 +38,7 @@ import Prelude hiding (lookup) import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.ConnMap as ConnMap import Ouroboros.Network.ConnectionManager.Types +import Ouroboros.Network.PublicState qualified as PS import Test.Ouroboros.Network.Utils (WithName (..)) @@ -182,6 +184,17 @@ abstractState = \case go TerminatedState {} = TerminatedSt +toPublic :: Ord peerAddr + => ConnMap peerAddr AbstractState + -> PS.ConnectionManagerState peerAddr +toPublic st = PS.ConnectionManagerState { + PS.connectionMap + = ConnMap.toMap st, + PS.registeredOutboundConnections + = ConnMap.unknownSet st + } + + -- | State of a connection. -- data ConnectionState peerAddr handle handleError version m = diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs index aec1d7108a..2e67e3298d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs @@ -179,6 +179,7 @@ import Network.Mux.Types qualified as Mux import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap) +import Ouroboros.Network.ConnectionManager.Public import Ouroboros.Network.MuxMode import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) @@ -189,41 +190,6 @@ data AddressType = IPv4Address | IPv6Address deriving Show --- | Each connection is is either initiated locally (outbound) or by a remote --- peer (inbound). --- -data Provenance = - -- | An inbound connection: one that was initiated by a remote peer. - -- - Inbound - - -- | An outbound connection: one that was initiated by us. - -- - | Outbound - deriving (Eq, Ord, Show) - - --- | Each connection negotiates if it is uni- or bi-directional. 'DataFlow' --- is a life time property of a connection, once negotiated it never changes. --- --- NOTE: This type is isomorphic to `DiffusionMode` for `node-to-node` --- connections (see `Ouroboros.Network.Diffusion.P2P.ntnDataFlow`), but it isn't --- for `node-to-client` connections (see --- `Ouroboros.Network.Diffusion.P2P.ntcDataFlow). --- -data DataFlow - = Unidirectional - | Duplex - deriving (Eq, Ord, Show) - - --- | Boolean like type which indicates if the timeout on 'OutboundStateDuplex' --- has expired. -data TimeoutExpired = Expired | Ticking - deriving (Eq, Ord, Show) - - - -- | Either unnegotiated or negotiated unidirectional or duplex connections. -- This is not a static property of a connection. It is used by 'PrunePolicy'. -- @@ -666,26 +632,6 @@ numberOfConnections = -- --- | Useful for tracing and error messages. --- -data AbstractState = - -- | Unknown connection. This state indicates the connection manager - -- removed this connection from its state. - UnknownConnectionSt - | ReservedOutboundSt - | UnnegotiatedSt !Provenance - | InboundIdleSt !DataFlow - | InboundSt !DataFlow - | OutboundUniSt - | OutboundDupSt !TimeoutExpired - | OutboundIdleSt !DataFlow - | DuplexSt - | WaitRemoteIdleSt - | TerminatingSt - | TerminatedSt - deriving (Eq, Ord, Show) - - -- | Counters for tracing and analysis purposes -- data ConnectionManagerCounters = ConnectionManagerCounters { diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index 940c839090..46eea566df 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -123,6 +123,7 @@ module Ouroboros.Network.PeerSelection.Governor.Types , newCapturePublicStateVar , requestPublicState , handlePublicStateRequest + , toOutboundState -- * Traces , TracePeerSelection (..) , ChurnAction (..) @@ -171,6 +172,9 @@ import Cardano.Network.Types (LedgerStateJudgement (..)) import Ouroboros.Cardano.Network.Types (ChurnMode) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) +import Ouroboros.Network.PublicState qualified as PS + + -- | A peer pick policy is an action that picks a subset of elements from a -- map of peers. -- @@ -1928,3 +1932,17 @@ handlePublicStateRequest (CapturePublicStateVar v) st = do case a of RequestState -> writeTMVar v (CapturedState st) (CapturedState _) -> retry + +toOutboundState :: Ord peeraddr + => PublicPeerSelectionState peeraddr + -> PS.OutboundState peeraddr +toOutboundState PublicPeerSelectionState { + knownSet, + establishedSet, + activeSet + } = + PS.OutboundState { + PS.coldPeers = knownSet `Set.difference` establishedSet, + PS.warmPeers = establishedSet `Set.difference` activeSet, + PS.hotPeers = activeSet + } From fbe6867460ab328c788c5bf7a40827fccd30deb3 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 27 Dec 2024 15:57:04 +0100 Subject: [PATCH 07/12] diffusion: public network state --- .../src/Cardano/Client/Subscription.hs | 10 +- .../ouroboros-network-api.cabal | 58 ++++++ ouroboros-network-api/test/Main.hs | 14 ++ .../Test/Ouroboros/Network/PublicState.hs | 57 ++++++ .../Network/PublicState/Generators.hs | 191 ++++++++++++++++++ .../src/Ouroboros/Network/InboundGovernor.hs | 1 + .../Network/InboundGovernor/State.hs | 23 +++ .../src/Ouroboros/Network/Diffusion.hs | 127 ++++++++---- .../src/Ouroboros/Network/Diffusion/Types.hs | 57 +++--- .../src/Ouroboros/Network/NodeToClient.hs | 38 ++-- .../src/Ouroboros/Network/NodeToNode.hs | 20 +- .../Network/PeerSelection/Governor.hs | 1 + .../Network/Diffusion/Node/MiniProtocols.hs | 3 +- 13 files changed, 512 insertions(+), 88 deletions(-) create mode 100644 ouroboros-network-api/test/Main.hs create mode 100644 ouroboros-network-api/test/Test/Ouroboros/Network/PublicState.hs create mode 100644 ouroboros-network-api/testlib/Test/Ouroboros/Network/PublicState/Generators.hs diff --git a/cardano-client/src/Cardano/Client/Subscription.hs b/cardano-client/src/Cardano/Client/Subscription.hs index a5db6ebc8c..0efb7168bf 100644 --- a/cardano-client/src/Cardano/Client/Subscription.hs +++ b/cardano-client/src/Cardano/Client/Subscription.hs @@ -50,6 +50,8 @@ import Ouroboros.Network.NodeToClient (Handshake, LocalAddress (..), NodeToClientVersion, NodeToClientVersionData (..), TraceSendRecv, Versions) import Ouroboros.Network.NodeToClient qualified as NtC +import Ouroboros.Network.NodeToNode (RemoteAddress) +import Ouroboros.Network.PublicState qualified as Public import Ouroboros.Network.Snocket qualified as Snocket type MuxMode = Mx.Mode @@ -104,7 +106,7 @@ subscribe -> SubscriptionParams a -> ( NodeToClientVersion -> blockVersion - -> NodeToClientProtocols Mx.InitiatorMode LocalAddress BSL.ByteString IO a Void) + -> NodeToClientProtocols Mx.InitiatorMode RemoteAddress LocalAddress BSL.ByteString IO a Void) -> IO () subscribe snocket networkMagic supportedVersions SubscriptionTracers { @@ -154,7 +156,7 @@ versionedProtocols :: -- ^ Use `supportedNodeToClientVersions` from `ouroboros-consensus`. -> ( NodeToClientVersion -> blockVersion - -> NodeToClientProtocols appType LocalAddress bytes m a Void) + -> NodeToClientProtocols appType RemoteAddress LocalAddress bytes m a Void) -- ^ callback which receives codecs, connection id and STM action which -- can be checked if the networking runtime system requests the protocols -- to stop. @@ -165,7 +167,7 @@ versionedProtocols :: -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a Void) + (OuroborosApplicationWithMinimalCtx appType (Public.NetworkState RemoteAddress) LocalAddress bytes m a Void) versionedProtocols networkMagic supportedVersions callback = NtC.foldMapVersions applyVersion (Map.toList supportedVersions) where @@ -174,7 +176,7 @@ versionedProtocols networkMagic supportedVersions callback = -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a Void) + (OuroborosApplicationWithMinimalCtx appType (Public.NetworkState RemoteAddress) LocalAddress bytes m a Void) applyVersion (version, blockVersion) = NtC.versionedNodeToClientProtocols version diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index f51409facf..5f5572bb62 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -97,3 +97,61 @@ library if flag(asserts) ghc-options: -fno-ignore-asserts + +library testlib + visibility: public + hs-source-dirs: testlib + exposed-modules: + Test.Ouroboros.Network.PublicState.Generators + + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: + QuickCheck, + base, + containers, + ouroboros-network-api, + + ghc-options: + -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wunused-packages + + if flag(asserts) + ghc-options: -fno-ignore-asserts + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Test.Ouroboros.Network.PublicState + + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: + base, + bytestring, + cborg, + ouroboros-network-api:{ouroboros-network-api, testlib}, + serialise, + tasty, + tasty-quickcheck, + with-utf8, + + ghc-options: + -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wunused-packages diff --git a/ouroboros-network-api/test/Main.hs b/ouroboros-network-api/test/Main.hs new file mode 100644 index 0000000000..c3446d8ca8 --- /dev/null +++ b/ouroboros-network-api/test/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Test.Ouroboros.Network.PublicState qualified as PublicState + +import Main.Utf8 (withUtf8) +import Test.Tasty + +main :: IO () +main = withUtf8 $ defaultMain tests + +tests :: TestTree +tests = + testGroup "ouroboros-network-api:test" + [ PublicState.tests ] diff --git a/ouroboros-network-api/test/Test/Ouroboros/Network/PublicState.hs b/ouroboros-network-api/test/Test/Ouroboros/Network/PublicState.hs new file mode 100644 index 0000000000..ee0fb21c2c --- /dev/null +++ b/ouroboros-network-api/test/Test/Ouroboros/Network/PublicState.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.PublicState where + +import Codec.CBOR.FlatTerm qualified as CBOR +import Codec.CBOR.Read qualified as CBOR +import Codec.CBOR.Write qualified as CBOR +import Codec.Serialise +import Data.ByteString.Lazy qualified as BSL + +import Ouroboros.Network.PublicState +import Test.Ouroboros.Network.PublicState.Generators () + +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: TestTree +tests = testGroup "Test.Ouroboros.Network.PublicState" + [ testGroup "CBOR" + [ testProperty "round trip" prop_publicState_roundTripCBOR + , testProperty "valid encoding" prop_publicState_validCBOR + ] + ] + + +type Addr = Int + +instance Serialise (RemoteAddressEncoding Addr) where + encode = encode . getRemoteAddressEncoding + decode = RemoteAddressEncoding <$> decode + +prop_publicState_roundTripCBOR + :: NetworkState Addr + -> Property +prop_publicState_roundTripCBOR ns = + case CBOR.deserialiseFromBytes decodeNetworkState (CBOR.toLazyByteString (encodeNetworkState ns)) of + Left e -> counterexample (show e) False + Right (bs, ns') | BSL.null bs + -> ns' === ns + + | otherwise + -> counterexample "left over bytes" False + +prop_publicState_validCBOR + :: NetworkState Addr + -> Property +prop_publicState_validCBOR ns = + counterexample (show enc) + . CBOR.validFlatTerm + . CBOR.toFlatTerm + $ enc + where + enc = encodeNetworkState ns + + diff --git a/ouroboros-network-api/testlib/Test/Ouroboros/Network/PublicState/Generators.hs b/ouroboros-network-api/testlib/Test/Ouroboros/Network/PublicState/Generators.hs new file mode 100644 index 0000000000..d0160d5692 --- /dev/null +++ b/ouroboros-network-api/testlib/Test/Ouroboros/Network/PublicState/Generators.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.PublicState.Generators where + +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set + +import Ouroboros.Network.ConnectionId +import Ouroboros.Network.ConnectionManager.Public +import Ouroboros.Network.PublicState + +import Test.QuickCheck + + +instance Arbitrary Provenance where + arbitrary = elements [Inbound, Outbound] + +instance Arbitrary DataFlow where + arbitrary = elements [Unidirectional, Duplex] + +instance Arbitrary TimeoutExpired where + arbitrary = elements [Expired, Ticking] + +instance Arbitrary AbstractState where + arbitrary = oneof + [ pure UnknownConnectionSt + , pure ReservedOutboundSt + , UnnegotiatedSt <$> arbitrary + , InboundIdleSt <$> arbitrary + , InboundSt <$> arbitrary + , pure OutboundUniSt + , OutboundDupSt <$> arbitrary + , OutboundIdleSt <$> arbitrary + , pure DuplexSt + , pure WaitRemoteIdleSt + , pure TerminatingSt + , pure TerminatedSt + ] + +toPair :: ConnectionId addr -> (addr, addr) +toPair ConnectionId {remoteAddress, localAddress} = (remoteAddress, localAddress) + +fromPair :: (addr, addr) -> ConnectionId addr +fromPair (remoteAddress, localAddress) = ConnectionId {remoteAddress, localAddress} + +instance (Ord addr, Arbitrary addr) => Arbitrary (ConnectionManagerState addr) where + arbitrary = do + connectionMap <- Map.fromList + <$> listOf ((\(a,b,c) -> (ConnectionId a b, c)) + `fmap` + ((,,) <$> arbitrary + <*> arbitrary + <*> arbitrary)) + registered <- Set.fromList <$> arbitrary + let registeredOutboundConnections = + registered + `Set.difference` + Set.map remoteAddress (Map.keysSet connectionMap) + return ConnectionManagerState { + connectionMap, + registeredOutboundConnections + } + + shrink a@ConnectionManagerState { + connectionMap, + registeredOutboundConnections + } = + [ a { connectionMap = connectionMap' } + | connectionMap' + <- Map.fromList `map` shrinkList (const []) (Map.toList connectionMap) + ] + ++ + [ a { registeredOutboundConnections = registeredOutboundConnections' } + | registeredOutboundConnections' + <- Set.fromList `map` shrinkList (const []) (Set.toList registeredOutboundConnections) + ] + +disjoint3 :: Ord a => Gen a -> Gen (Set a, Set a, Set a) +disjoint3 gen = do + (a,b,c) <- + (,,) <$> (Set.fromList <$> listOf gen) + <*> (Set.fromList <$> listOf gen) + <*> (Set.fromList <$> listOf gen) + return ( a + , b `Set.difference` a + , c `Set.difference` a + `Set.difference` b + ) + +disjoint4 :: Ord a => Gen a -> Gen (Set a, Set a, Set a, Set a) +disjoint4 gen = do + (a,b,c,d) <- + (,,,) <$> (Set.fromList <$> listOf gen) + <*> (Set.fromList <$> listOf gen) + <*> (Set.fromList <$> listOf gen) + <*> (Set.fromList <$> listOf gen) + return ( a + , b `Set.difference` a + , c `Set.difference` a + `Set.difference` b + , d `Set.difference` a + `Set.difference` b + `Set.difference` c + ) + + +instance (Ord addr, Arbitrary addr) => Arbitrary (InboundState addr) where + arbitrary = do + (remoteHotSet, remoteWarmSet, remoteColdSet, remoteIdleSet) + <- disjoint4 (ConnectionId <$> arbitrary <*> arbitrary) + return InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + } + shrink a@InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + } = + [ a { remoteHotSet = remoteHotSet' } + | remoteHotSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteHotSet) + ] + ++ + [ a { remoteWarmSet = remoteWarmSet' } + | remoteWarmSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteWarmSet) + ] + ++ + [ a { remoteColdSet = remoteColdSet' } + | remoteColdSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteColdSet) + ] + ++ + [ a { remoteIdleSet = remoteIdleSet' } + | remoteIdleSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteIdleSet) + ] + +instance (Ord addr, Arbitrary addr) => Arbitrary (OutboundState addr) where + arbitrary = do + (coldPeers, warmPeers, hotPeers) + <- disjoint3 arbitrary + return OutboundState { + coldPeers, + warmPeers, + hotPeers + } + shrink a@OutboundState { + coldPeers, + warmPeers, + hotPeers + } = + [ a { coldPeers = coldPeers' } + | coldPeers' <- Set.fromList `map` shrink (Set.toList coldPeers) + ] + ++ + [ a { warmPeers = warmPeers' } + | warmPeers' <- Set.fromList `map` shrink (Set.toList warmPeers) + ] + ++ + [ a { hotPeers = hotPeers' } + | hotPeers' <- Set.fromList `map` shrink (Set.toList hotPeers) + ] + +instance (Ord addr, Arbitrary addr) => Arbitrary (NetworkState addr) where + arbitrary = + NetworkState + <$> arbitrary + <*> arbitrary + <*> arbitrary + + shrink a@NetworkState { + connectionManagerState, + inboundGovernorState, + outboundGovernorState + } = + [ a { connectionManagerState = connectionManagerState' } + | connectionManagerState' <- shrink connectionManagerState + ] + ++ + [ a { inboundGovernorState = inboundGovernorState' } + | inboundGovernorState' <- shrink inboundGovernorState + ] + ++ + [ a { outboundGovernorState = outboundGovernorState' } + | outboundGovernorState' <- shrink outboundGovernorState + ] + + diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index bb548c0db7..846b0bb173 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -20,6 +20,7 @@ module Ouroboros.Network.InboundGovernor ( -- * Run Inbound Protocol Governor PublicState (..) + , toInboundState , newPublicStateVar , emptyPublicState , Arguments (..) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs index b71d34821f..d31f55efa8 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs @@ -12,6 +12,7 @@ module Ouroboros.Network.InboundGovernor.State ( PublicState (..) , emptyPublicState + , toInboundState , newPublicStateVar -- * Internals , mkPublicState @@ -40,11 +41,13 @@ import Data.Cache (Cache) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.OrdPSQ as OrdPSQ +import Data.Set qualified as Set import Network.Mux qualified as Mux import Ouroboros.Network.Context import Ouroboros.Network.Mux +import Ouroboros.Network.PublicState (InboundState (..), emptyInboundState) -- | Remote connection state tracked by inbound protocol governor. -- @@ -73,12 +76,32 @@ data PublicState peerAddr versionData = PublicState { } + emptyPublicState :: PublicState peerAddr versionData emptyPublicState = PublicState { inboundDuplexPeers = Map.empty, remoteStateMap = Map.empty } + +toInboundState :: Ord peerAddr => PublicState peerAddr versionData -> InboundState peerAddr +toInboundState PublicState { remoteStateMap } = + Map.foldrWithKey' + (\connId rs is@InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + } -> case rs of + RemoteHotSt -> is { remoteHotSet = connId `Set.insert` remoteHotSet } + RemoteWarmSt -> is { remoteWarmSet = connId `Set.insert` remoteWarmSet } + RemoteColdSt -> is { remoteColdSet = connId `Set.insert` remoteColdSet } + RemoteIdleSt -> is { remoteIdleSet = connId `Set.insert` remoteIdleSet } + ) + emptyInboundState + remoteStateMap + + newPublicStateVar :: MonadSTM m => m (StrictTVar m (PublicState peerAddr versionData)) newPublicStateVar = newTVarIO emptyPublicState diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 7e3ca21ae3..19b78ba81f 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -16,6 +16,8 @@ module Ouroboros.Network.Diffusion ( Tracers (..) , nullTracers , Arguments (..) + , NodeToNode.NodeToNodeApplication + , NodeToClient.NodeToClientApplication , run , Interfaces (..) , runM @@ -25,7 +27,7 @@ module Ouroboros.Network.Diffusion ) where -import Control.Applicative (Alternative) +import Control.Applicative (Alternative, asum) import Control.Concurrent.Class.MonadMVar (MonadMVar) import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (IOException) @@ -38,14 +40,14 @@ import Control.Monad.Class.MonadTimer.SI import Control.Monad.Fix (MonadFix) import Control.Tracer (Tracer, contramap, nullTracer, traceWith) import Data.ByteString.Lazy (ByteString) -import Data.Function ((&)) import Data.Hashable (Hashable) import Data.IP qualified as IP import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes) -import Data.Typeable (Proxy (..), Typeable) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) import Data.Void (Void) import System.Exit (ExitCode) import System.Random (StdGen, newStdGen, split) @@ -87,6 +89,7 @@ import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Version +import Ouroboros.Network.PublicState qualified as Public import Ouroboros.Network.RethrowPolicy import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (LocalAddress, LocalSocket (..), @@ -250,12 +253,14 @@ runM Interfaces -- If we have a local address, race the remote and local threads. Otherwise -- just launch the remote thread. - mkRemoteThread mainThreadId & - (case daLocalAddress of - Nothing -> id - Just addr -> (fmap (either id id) . (`Async.race` mkLocalThread mainThreadId addr)) - ) - + withRemoteThreads mainThreadId $ \threads readPublicNetworkState -> + Async.runConcurrently + $ asum + $ Async.Concurrently + <$> ( case mkLocalThread readPublicNetworkState mainThreadId <$> daLocalAddress of + Nothing -> [snd <$> Async.waitAny threads] + Just th -> [snd <$> Async.waitAny threads, th] + ) where (ledgerPeersRng, rng1) = split diRng (policyRng, rng2) = split rng1 @@ -314,18 +319,19 @@ runM Interfaces -- | mkLocalThread - create local connection manager - - mkLocalThread :: ThreadId m -> Either ntcFd ntcAddr -> m Void - mkLocalThread mainThreadId localAddr = do - labelThisThread "local connection manager" - withLocalSocket tracer diNtcGetFileDescriptor diNtcSnocket localAddr - $ \localSocket -> do + mkLocalThread :: m (Public.NetworkState ntnAddr) + -> ThreadId m + -> Either ntcFd ntcAddr + -> m Void + mkLocalThread readPublicNetworkState mainThreadId localAddr = do + labelThisThread "local connection manager" + withLocalSocket tracer diNtcGetFileDescriptor diNtcSnocket localAddr $ \localSocket -> do localInbInfoChannel <- newInformationChannel let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 localConnectionHandler :: NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m + ntcFd ntnAddr ntcAddr ntcVersion ntcVersionData m localConnectionHandler = makeConnectionHandler dtLocalMuxTracer @@ -342,7 +348,7 @@ runM Interfaces localConnectionManagerArguments :: NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m + ntcFd ntnAddr ntcAddr ntcVersion ntcVersionData m localConnectionManagerArguments = CM.Arguments { CM.tracer = dtLocalConnectionManagerTracer, @@ -389,15 +395,17 @@ runM Interfaces Server.connectionManager = localConnectionManager, Server.connectionDataFlow = ntcDataFlow, Server.inboundInfoChannel = localInbInfoChannel, - Server.readNetworkState = return () + Server.readNetworkState = readPublicNetworkState } (\thread _ -> Async.wait thread) - -- | mkRemoteThread - create remote connection manager - - mkRemoteThread :: ThreadId m -> m Void - mkRemoteThread mainThreadId = do + -- | withRemoteThreads - create remote connection manager + withRemoteThreads :: forall x. + ThreadId m + -> ([Async m Void] -> m (Public.NetworkState ntnAddr) -> m x) + -> m x + withRemoteThreads mainThreadId k = do labelThisThread "remote connection manager" let exitPolicy :: ExitPolicy a @@ -500,9 +508,9 @@ runM Interfaces :: forall muxMode socket initiatorCtx responderCtx b c. SingMuxMode muxMode -> Versions ntnVersion ntnVersionData - (OuroborosBundle muxMode initiatorCtx responderCtx NetworkState ByteString m b c) + (OuroborosBundle muxMode initiatorCtx responderCtx UnitNetworkState ByteString m b c) -> MuxConnectionHandler - muxMode socket initiatorCtx responderCtx NetworkState ntnAddr + muxMode socket initiatorCtx responderCtx UnitNetworkState ntnAddr ntnVersion ntnVersionData ByteString m b c makeConnectionHandler' muxMode versions = makeConnectionHandler @@ -552,11 +560,11 @@ runM Interfaces HasInitiator muxMode ~ True => MuxConnectionManager muxMode socket (ExpandedInitiatorContext ntnAddr m) - responderCtx NetworkState ntnAddr ntnVersionData ntnVersion + responderCtx UnitNetworkState ntnAddr ntnVersionData ntnVersion ByteString m a b -> (Governor.PeerStateActions ntnAddr - (PeerConnectionHandle muxMode responderCtx NetworkState ntnAddr + (PeerConnectionHandle muxMode responderCtx UnitNetworkState ntnAddr ntnVersionData ByteString m a b) m -> m c) @@ -590,7 +598,7 @@ runM Interfaces -> PeerStateActions ntnAddr (PeerConnectionHandle - muxMode responderCtx NetworkState ntnAddr ntnVersionData bytes m a' b) + muxMode responderCtx UnitNetworkState ntnAddr ntnVersionData bytes m a' b) m -> ( (Async m Void, Async m Void) -> PeerSelectionActions @@ -601,7 +609,7 @@ runM Interfaces extraCounters ntnAddr (PeerConnectionHandle - muxMode responderCtx NetworkState ntnAddr ntnVersionData bytes m a' b) + muxMode responderCtx UnitNetworkState ntnAddr ntnVersionData bytes m a' b) m -> m c) -> m c @@ -653,11 +661,11 @@ runM Interfaces peerSelectionGovernor' :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) -> StrictTVar m (PeerSelectionState extraState extraFlags extraPeers ntnAddr - (PeerConnectionHandle muxMode responderCtx NetworkState ntnAddr ntnVersionData ByteString m a b)) + (PeerConnectionHandle muxMode responderCtx UnitNetworkState ntnAddr ntnVersionData ByteString m a b)) -> PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters ntnAddr - (PeerConnectionHandle muxMode responderCtx NetworkState ntnAddr ntnVersionData ByteString m a b) + (PeerConnectionHandle muxMode responderCtx UnitNetworkState ntnAddr ntnVersionData ByteString m a b) m -> m Void peerSelectionGovernor' peerSelectionTracer dbgVar peerSelectionActions = @@ -682,7 +690,8 @@ runM Interfaces -- -- The peer churn governor: -- - let peerChurnGovernor' = + let peerChurnGovernor' :: m Void + peerChurnGovernor' = daPeerChurnGovernor PeerChurnArgs { pcaPeerSelectionTracer = dtTracePeerSelectionTracer @@ -759,9 +768,15 @@ runM Interfaces peerSelectionActions) $ \governorThread -> Async.withAsync peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny - [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread] + k [ ledgerPeersThread + , localRootPeersProvider + , governorThread + , churnGovernorThread + ] + (publicNetworkStateSTM + (readState connectionManager) + daCapturePublicStateVar + (pure IG.emptyPublicState)) -- InitiatorAndResponder mode, run peer selection and the server: InitiatorAndResponderDiffusionMode -> do @@ -802,17 +817,45 @@ runM Interfaces -- begin, unique to InitiatorAndResponder mode: traceWith tracer (RunServer addresses) -- end, unique to ... - Async.withAsync (do - labelThisThread "Peer churn governor" + Async.withAsync (do labelThisThread "Peer churn governor" peerChurnGovernor') $ \churnGovernorThread -> -- wait for any thread to fail: - snd <$> Async.waitAny [ ledgerPeersThread - , localRootPeersProvider - , governorThread - , churnGovernorThread - , inboundGovernorThread - ] + k [ ledgerPeersThread + , localRootPeersProvider + , governorThread + , churnGovernorThread + , inboundGovernorThread + ] + (publicNetworkStateSTM + (readState connectionManager) + daCapturePublicStateVar + (pure IG.emptyPublicState)) + + +publicNetworkStateSTM + :: ( MonadSTM m + , Ord addr + ) + => STM m (CM.ConnMap addr AbstractState) + -> Governor.CapturePublicStateVar addr m + -> STM m (IG.PublicState addr versionData) + -> m (Public.NetworkState addr) +publicNetworkStateSTM readCMState capturePublicStateVar readInboundGovState = do + (connMap, inboundState) + <- atomically $ (,) <$> readCMState + <*> readInboundGovState + outboundState + <- Governor.requestPublicState capturePublicStateVar + return Public.NetworkState { + Public.connectionManagerState = Public.ConnectionManagerState { + Public.connectionMap = CM.toMap connMap, + Public.registeredOutboundConnections = CM.unknownSet connMap + }, + Public.inboundGovernorState = IG.toInboundState inboundState, + Public.outboundGovernorState = Governor.toOutboundState outboundState + } + -- | Main entry point for data diffusion service. It allows to: -- diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs index 2d1d06749d..c872b27519 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -23,7 +23,7 @@ module Ouroboros.Network.Diffusion.Types , NodeToClientConnectionHandler , NodeToClientConnectionManagerArguments -- * NodeToNode type aliases - , NetworkState + , NodeToNode.UnitNetworkState , NodeToNodeHandle , NodeToNodeConnectionManager , NodeToNodePeerConnectionHandle @@ -31,6 +31,8 @@ module Ouroboros.Network.Diffusion.Types -- * Re-exports , AbstractTransitionTrace , IG.RemoteTransitionTrace + , NodeToNode.NodeToNodeApplication + , NodeToClient.NodeToClientApplication ) where import Control.Concurrent.Class.MonadSTM.Strict @@ -49,9 +51,6 @@ import System.Random (StdGen) import Network.Mux qualified as Mx import Network.Socket qualified as Socket -import Ouroboros.Network.Mux (OuroborosApplicationWithMinimalCtx, - OuroborosBundleWithExpandedCtx) - import Ouroboros.Network.BlockFetch import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) @@ -76,6 +75,7 @@ import Ouroboros.Network.PeerSelection as PeerSelection import Ouroboros.Network.PeerSelection.Governor.Types as Governor import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers +import Ouroboros.Network.PublicState qualified as Public -- | The 'DiffusionTracer' logs -- @@ -105,8 +105,6 @@ data DiffusionTracer ntnAddr ntcAddr | SystemdSocketConfiguration SystemdSocketTracer deriving Show -type NetworkState = () - -- TODO: add a tracer for these misconfiguration data Failure where UnsupportedReadySocket :: Failure @@ -355,7 +353,7 @@ data Arguments extraState extraDebugState extraFlags extraPeers PeerSelectionGovernorArgs extraState extraDebugState extraFlags extraPeers extraAPI extraCounters ntnAddr (PeerConnectionHandle - muxMode responderCtx NetworkState ntnAddr + muxMode responderCtx NodeToNode.UnitNetworkState ntnAddr ntnVersionData bytes m a b) exception m @@ -365,7 +363,7 @@ data Arguments extraState extraDebugState extraFlags extraPeers :: forall muxMode responderCtx ntnVersionData bytes a b . PeerSelectionState extraState extraFlags extraPeers ntnAddr (PeerConnectionHandle - muxMode responderCtx NetworkState ntnAddr + muxMode responderCtx NodeToNode.UnitNetworkState ntnAddr ntnVersionData bytes m a b) -> extraCounters @@ -420,7 +418,6 @@ data Arguments extraState extraDebugState extraFlags extraPeers } - -- | Versioned mini-protocol bundles run on a negotiated connection. -- data Applications ntnAddr ntnVersion ntnVersionData @@ -436,9 +433,8 @@ data Applications ntnAddr ntnVersion ntnVersionData daApplicationInitiatorMode :: Versions ntnVersion ntnVersionData - (OuroborosBundleWithExpandedCtx - Mx.InitiatorMode () ntnAddr - ByteString m a Void) + (NodeToNode.NodeToNodeApplication + Mx.InitiatorMode ntnAddr ByteString m a Void) -- | NodeToNode initiator & responder applications for bidirectional mode. -- @@ -446,9 +442,8 @@ data Applications ntnAddr ntnVersion ntnVersionData -- Peer Sharing result computation callback :: Versions ntnVersion ntnVersionData - (OuroborosBundleWithExpandedCtx - Mx.InitiatorResponderMode () ntnAddr - ByteString m a ()) + (NodeToNode.NodeToNodeApplication + Mx.InitiatorResponderMode ntnAddr ByteString m a ()) -- | NodeToClient responder application (server role) -- @@ -457,9 +452,7 @@ data Applications ntnAddr ntnVersion ntnVersionData , daLocalResponderApplication :: Versions ntcVersion ntcVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode () ntcAddr - ByteString m Void ()) + (NodeToClient.NodeToClientApplication Mx.ResponderMode ntnAddr ntcAddr ByteString m Void ()) -- | Interface used to get peers from the current ledger. -- @@ -496,35 +489,37 @@ data Applications ntnAddr ntnVersion ntnVersionData -- -- Node-To-Client type aliases -- --- Node-To-Client diffusion is only used in 'ResponderMode'. +-- Node-To-Client diffusion is only used in 'ResponderMode', it has access to +-- `Public.NetworkState` for the purpose of making it available through one of +-- the mini-protocols. -- -type NodeToClientHandle ntcAddr versionData m = - HandleWithMinimalCtx Mx.ResponderMode NetworkState ntcAddr versionData ByteString m Void () +type NodeToClientHandle ntnAddr ntcAddr versionData m = + HandleWithMinimalCtx Mx.ResponderMode (Public.NetworkState ntnAddr) ntcAddr versionData ByteString m Void () type NodeToClientHandleError ntcVersion = HandleError Mx.ResponderMode ntcVersion type NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m = + ntcFd ntnAddr ntcAddr ntcVersion ntcVersionData m = ConnectionHandler Mx.ResponderMode (ConnectionHandlerTrace ntcVersion ntcVersionData) ntcFd ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandle ntnAddr ntcAddr ntcVersionData m) (NodeToClientHandleError ntcVersion) ntcVersion ntcVersionData m type NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m = + ntcFd ntnAddr ntcAddr ntcVersion ntcVersionData m = CM.Arguments (ConnectionHandlerTrace ntcVersion ntcVersionData) ntcFd ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandle ntnAddr ntcAddr ntcVersionData m) (NodeToClientHandleError ntcVersion) ntcVersion ntcVersionData @@ -535,12 +530,20 @@ type NodeToClientConnectionManagerArguments -- Node-To-Node type aliases -- -- Node-To-Node diffusion runs in either 'InitiatorMode' or 'InitiatorResponderMode'. +-- We don't expose network state through Node-to-Node Protocol, hence +-- `UnitNetworkState`. -- type NodeToNodeHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = - HandleWithExpandedCtx mode NetworkState ntnAddr ntnVersionData ByteString m a b + HandleWithExpandedCtx + mode + NodeToNode.UnitNetworkState + ntnAddr + ntnVersionData + ByteString + m a b type NodeToNodeConnectionManager (mode :: Mx.Mode) @@ -561,7 +564,7 @@ type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a PeerConnectionHandle mode (ResponderContext ntnAddr) - NetworkState + NodeToNode.UnitNetworkState ntnAddr ntnVersionData ByteString diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 9260d05b1b..24407d360f 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -13,6 +13,7 @@ module Ouroboros.Network.NodeToClient ( nodeToClientProtocols , NodeToClientProtocols (..) + , NodeToClientApplication , NodeToClientVersion (..) , NodeToClientVersionData (..) , NetworkConnectTracers (..) @@ -73,6 +74,7 @@ import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.NodeToClient.Version +import Ouroboros.Network.NodeToNode (RemoteAddress) import Ouroboros.Network.Protocol.ChainSync.Client as ChainSync import Ouroboros.Network.Protocol.ChainSync.Type qualified as ChainSync import Ouroboros.Network.Protocol.Handshake.Codec @@ -84,6 +86,7 @@ import Ouroboros.Network.Protocol.LocalTxMonitor.Client as LocalTxMonitor import Ouroboros.Network.Protocol.LocalTxMonitor.Type qualified as LocalTxMonitor import Ouroboros.Network.Protocol.LocalTxSubmission.Client as LocalTxSubmission import Ouroboros.Network.Protocol.LocalTxSubmission.Type qualified as LocalTxSubmission +import Ouroboros.Network.PublicState qualified as Public import Ouroboros.Network.Snocket import Ouroboros.Network.Socket @@ -95,28 +98,39 @@ type HandshakeTr ntcAddr ntcVersion = -- | Record of node-to-client mini protocols. -- -data NodeToClientProtocols appType ntcAddr bytes m a b = NodeToClientProtocols { +data NodeToClientProtocols appType ntnAddr ntcAddr bytes m a b = NodeToClientProtocols { -- | local chain-sync mini-protocol -- localChainSyncProtocol :: RunMiniProtocolWithMinimalCtx - appType () ntcAddr bytes m a b, + appType (Public.NetworkState ntnAddr) ntcAddr bytes m a b, -- | local tx-submission mini-protocol -- localTxSubmissionProtocol :: RunMiniProtocolWithMinimalCtx - appType () ntcAddr bytes m a b, + appType (Public.NetworkState ntnAddr) ntcAddr bytes m a b, -- | local state-query mini-protocol -- localStateQueryProtocol :: RunMiniProtocolWithMinimalCtx - appType () ntcAddr bytes m a b, + appType (Public.NetworkState ntnAddr) ntcAddr bytes m a b, -- | local tx-monitor mini-protocol -- localTxMonitorProtocol :: RunMiniProtocolWithMinimalCtx - appType () ntcAddr bytes m a b + appType (Public.NetworkState ntnAddr) ntcAddr bytes m a b } +-- | A type alias for the node-to-client protocol bundle used by diffusion. It +-- is more general what we need in `Applications` type so it can be used in +-- `ouroboros-cosnensus-diffusion` (polymorphic `bytes` and result type `a`). +-- +type NodeToClientApplication muxMode ntnAddr ntcAddr bytes m a b = + OuroborosApplicationWithMinimalCtx + muxMode + (Public.NetworkState ntnAddr) + ntcAddr + bytes + m a b -- | Make an 'OuroborosApplication' for the bundle of mini-protocols that -- make up the overall node-to-client protocol. @@ -130,10 +144,10 @@ data NodeToClientProtocols appType ntcAddr bytes m a b = NodeToClientProtocols { -- wireshark plugins. -- nodeToClientProtocols - :: NodeToClientProtocols appType addr bytes m a b + :: NodeToClientProtocols muxMode ntnAddr ntcAddr bytes m a b -> NodeToClientVersion -> NodeToClientVersionData - -> OuroborosApplicationWithMinimalCtx appType () addr bytes m a b + -> NodeToClientApplication muxMode ntnAddr ntcAddr bytes m a b nodeToClientProtocols protocols _version _versionData = OuroborosApplication $ case protocols of @@ -187,10 +201,10 @@ maximumMiniProtocolLimits = versionedNodeToClientProtocols :: NodeToClientVersion -> NodeToClientVersionData - -> NodeToClientProtocols appType LocalAddress bytes m a b + -> NodeToClientProtocols appType RemoteAddress LocalAddress bytes m a b -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a b) + (OuroborosApplicationWithMinimalCtx appType (Public.NetworkState RemoteAddress) LocalAddress bytes m a b) versionedNodeToClientProtocols versionNumber versionData protocols = simpleSingletonVersions versionNumber @@ -208,7 +222,7 @@ connectTo -> Versions NodeToClientVersion NodeToClientVersionData (OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode () LocalAddress BL.ByteString IO a Void) + Mx.InitiatorMode (Public.NetworkState RemoteAddress) LocalAddress BL.ByteString IO a Void) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). @@ -246,7 +260,7 @@ connectToWithMux -> Versions NodeToClientVersion NodeToClientVersionData (OuroborosApplicationWithMinimalCtx - Mx.InitiatorMode () LocalAddress BL.ByteString IO a b) + Mx.InitiatorMode (Public.NetworkState RemoteAddress) LocalAddress BL.ByteString IO a b) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). @@ -255,7 +269,7 @@ connectToWithMux -> ( ConnectionId LocalAddress -> NodeToClientVersion -> NodeToClientVersionData - -> OuroborosApplicationWithMinimalCtx Mx.InitiatorMode () LocalAddress BL.ByteString IO a b + -> OuroborosApplicationWithMinimalCtx Mx.InitiatorMode (Public.NetworkState RemoteAddress) LocalAddress BL.ByteString IO a b -> Mx.Mux Mx.InitiatorMode IO -> Async.Async () -> IO x) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 1c9c461f0f..530222f2e7 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -14,6 +14,8 @@ module Ouroboros.Network.NodeToNode ( nodeToNodeProtocols , NodeToNodeProtocols (..) + , NodeToNodeApplication + , UnitNetworkState , NodeToNodeProtocolsWithExpandedCtx , NodeToNodeProtocolsWithMinimalCtx , MiniProtocolParameters (..) @@ -56,6 +58,7 @@ module Ouroboros.Network.NodeToNode , ProtocolLimitFailure , Handshake , Socket + , CapturePublicStateVar -- ** Exceptions , ExceptionInHandler (..) -- ** Traces @@ -86,8 +89,8 @@ import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) import Ouroboros.Network.Mux import Ouroboros.Network.NodeToNode.Version -import Ouroboros.Network.PeerSelection.Governor.Types - (PeerSelectionTargets (..)) +import Ouroboros.Network.PeerSelection.Governor.Types (CapturePublicStateVar, + PeerSelectionTargets (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Protocol.Handshake.Codec @@ -166,6 +169,19 @@ defaultMiniProtocolParameters = MiniProtocolParameters { , txSubmissionMaxUnacked = 10 } +-- We don't expose network state over node-t-node protocol. +type UnitNetworkState = () + + +-- | A type alias for the node-to-node protocol bundle used by diffusion. It +-- is more general what we need in `Applications` type so it can be used in +-- `ouroboros-cosnensus-diffusion` (polymorphic `bytes`). +-- +type NodeToNodeApplication mode ntnAddr bytes m a b = + OuroborosBundleWithExpandedCtx + mode UnitNetworkState ntnAddr bytes m a b + + -- | Make an 'OuroborosApplication' for the bundle of mini-protocols that -- make up the overall node-to-node protocol. -- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs index 404c6b6b5e..a14995efb9 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs @@ -35,6 +35,7 @@ module Ouroboros.Network.PeerSelection.Governor , CapturePublicStateVar , newCapturePublicStateVar , PublicPeerSelectionState (..) + , toOutboundState , requestPublicState -- * Internals exported for testing , assertPeerSelectionState diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index f38ed1e5c2..c27c640b11 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -95,6 +95,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Client (peerSharingClientPeer) import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Server (peerSharingServerPeer) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing) +import Ouroboros.Network.PublicState qualified as Public import Ouroboros.Network.RethrowPolicy import Ouroboros.Network.Util.ShowProxy @@ -379,7 +380,7 @@ applications debugTracer nodeKernel localResponderApp :: OuroborosApplicationWithMinimalCtx - Mx.ResponderMode NetworkState NtCAddr ByteString m Void () + Mx.ResponderMode (Public.NetworkState NtNAddr) NtCAddr ByteString m Void () localResponderApp = OuroborosApplication [] chainSyncInitiator From 15d5e78642c077840eab95ada95c1db3d27b097f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 30 Dec 2024 08:54:53 +0100 Subject: [PATCH 08/12] testnet: enhanced counterexample for unit_peer_sharing --- .../Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index 78f0a3f3ef..11a7ff364f 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -4157,12 +4157,13 @@ unit_peer_sharing = counterexample (concat [ show ip_0 , " is not a member of received peers " , show receivedPeers + , " for " + , show addr ]) $ ip_0 `Set.member` receivedPeers verify _ _ = All True in - -- counterexample (ppEvents trace) $ counterexample (Map.foldrWithKey (\addr evs s -> concat [ "\n\n===== " , show addr , " =====\n\n" From de6d1803550be0204eb646cd02bceea4a496904c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 31 Dec 2024 08:41:20 +0100 Subject: [PATCH 09/12] Added NodeToClientV_21 --- .../src/Ouroboros/Network/NodeToClient/Version.hs | 7 +++++-- .../cddl/specs/handshake-node-to-client.cddl | 4 ++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs b/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs index d1ba3d5528..cf701a0e76 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs @@ -51,8 +51,9 @@ data NodeToClientVersion | NodeToClientV_19 -- ^ added @GetLedgerPeerSnapshot@ | NodeToClientV_20 - -- ^ added @QueryStakePoolDefaultVote@, - -- added @MsgGetMeasures@ / @MsgReplyGetMeasures@ to @LocalTxMonitor@ + -- ^ added @QueryStakePoolDefaultVote@ + | NodeToClientV_21 + -- ^ added @GetNetworkState@ deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData) -- | We set 16ths bit to distinguish `NodeToNodeVersion` and @@ -71,6 +72,7 @@ nodeToClientVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } NodeToClientV_18 -> enc 18 NodeToClientV_19 -> enc 19 NodeToClientV_20 -> enc 20 + NodeToClientV_21 -> enc 21 where enc :: Int -> CBOR.Term enc = CBOR.TInt . (`setBit` nodeToClientVersionBit) @@ -82,6 +84,7 @@ nodeToClientVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } 18 -> Right NodeToClientV_18 19 -> Right NodeToClientV_19 20 -> Right NodeToClientV_20 + 21 -> Right NodeToClientV_21 n -> Left (unknownTag n) where dec :: CBOR.Term -> Either (Text, Maybe Int) Int diff --git a/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl b/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl index b01f186960..437ea30045 100644 --- a/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl +++ b/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl @@ -19,8 +19,8 @@ versionTable = { * versionNumber => nodeToClientVersionData } ; as of version 2 (which is no longer supported) we set 15th bit to 1 -; 16 / 17 / 18 / 19 / 20 -versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 +; 16 / 17 / 18 / 19 / 20 / 21 +versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 ; As of version 15 and higher nodeToClientVersionData = [networkMagic, query] From e55ffbe723f8f8fdb84c20b5aba3d7cd2ef30110 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Jan 2025 17:16:45 +0100 Subject: [PATCH 10/12] NetworkState - ToJSON instances --- .../src/Ouroboros/Network/ConnectionId.hs | 13 ++++- .../Network/ConnectionManager/Public.hs | 54 +++++++++++++++++-- .../PeerSelection/PeerSharing/Codec.hs | 9 +++- .../src/Ouroboros/Network/PublicState.hs | 52 ++++++++++++++++-- 4 files changed, 117 insertions(+), 11 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/ConnectionId.hs b/ouroboros-network-api/src/Ouroboros/Network/ConnectionId.hs index b505db4af0..ea5a489bef 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/ConnectionId.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/ConnectionId.hs @@ -1,17 +1,18 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StaticPointers #-} module Ouroboros.Network.ConnectionId where import NoThunks.Class (InspectHeap (..), NoThunks) +import Data.Aeson qualified as Aeson import Data.Hashable +import Data.String (fromString) import GHC.Generics (Generic) import Ouroboros.Network.Util.ShowProxy (Proxy (..), ShowProxy (..)) @@ -29,6 +30,14 @@ data ConnectionId addr = ConnectionId { deriving NoThunks via InspectHeap (ConnectionId addr) deriving Functor +instance Aeson.ToJSON addr => Aeson.ToJSONKey (ConnectionId addr) where +instance Aeson.ToJSON addr => Aeson.ToJSON (ConnectionId addr) where + toEncoding ConnectionId {remoteAddress, localAddress} = + Aeson.pairs $ + fromString "remoteAddress" Aeson..= remoteAddress + <> fromString "localAddress" Aeson..= localAddress + + -- | Order first by `remoteAddress` then by `localAddress`. -- -- /Note:/ we relay on the fact that `remoteAddress` is an order diff --git a/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs b/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs index 1f5b4fd06d..f40f582dc2 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/ConnectionManager/Public.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + module Ouroboros.Network.ConnectionManager.Public ( Provenance (..) , DataFlow (..) @@ -5,6 +7,11 @@ module Ouroboros.Network.ConnectionManager.Public , AbstractState (..) ) where +import Data.Aeson qualified as Aeson +import Data.Aeson.Encoding qualified as Aeson +import Data.String (fromString) +import GHC.Generics + -- | Each connection is is either initiated locally (outbound) or by a remote -- peer (inbound). @@ -17,8 +24,10 @@ data Provenance = -- | An outbound connection: one that was initiated by us. -- | Outbound - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance Aeson.ToJSON Provenance where + toEncoding = Aeson.string . show -- | Each connection negotiates if it is uni- or bi-directional. 'DataFlow' -- is a life time property of a connection, once negotiated it never changes. @@ -31,13 +40,19 @@ data Provenance = data DataFlow = Unidirectional | Duplex - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Aeson.ToJSON DataFlow where + toEncoding = Aeson.string . show -- | Boolean like type which indicates if the timeout on 'OutboundStateDuplex' -- has expired. data TimeoutExpired = Expired | Ticking - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Aeson.ToJSON TimeoutExpired where + toEncoding = Aeson.string . show -- | Useful for tracing and error messages. @@ -57,4 +72,35 @@ data AbstractState = | WaitRemoteIdleSt | TerminatingSt | TerminatedSt - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Aeson.ToJSON AbstractState where + toEncoding UnknownConnectionSt = + Aeson.pairs $ fromString "type" Aeson..= "UnknownConnectionState" + toEncoding ReservedOutboundSt = + Aeson.pairs $ fromString "type" Aeson..= "ReservedOutboundState" + toEncoding (UnnegotiatedSt a) = + Aeson.pairs $ fromString "type" Aeson..= "UnnegotiatedState" + <> fromString "provenance" Aeson..= a + toEncoding (InboundIdleSt a) = + Aeson.pairs $ fromString "type" Aeson..= "InboundIdleState" + <> fromString "dataFlow" Aeson..= a + toEncoding (InboundSt a) = + Aeson.pairs $ fromString "type" Aeson..= "InboundState" + <> fromString "dataFlow" Aeson..= a + toEncoding OutboundUniSt = + Aeson.pairs $ fromString "type" Aeson..= "OutboundUnidirectionalState" + toEncoding (OutboundDupSt a) = + Aeson.pairs $ fromString "type" Aeson..= "OutboundDuplexState" + <> fromString "timeout" Aeson..= a + toEncoding (OutboundIdleSt a) = + Aeson.pairs $ fromString "type" Aeson..= "OutboundIdleState" + <> fromString "dataFlow" Aeson..= a + toEncoding DuplexSt = + Aeson.pairs $ fromString "type" Aeson..= "DuplexState" + toEncoding WaitRemoteIdleSt = + Aeson.pairs $ fromString "type" Aeson..= "WaitRemoteIdleState" + toEncoding TerminatingSt = + Aeson.pairs $ fromString "type" Aeson..= "TerminatingState" + toEncoding TerminatedSt = + Aeson.pairs $ fromString "type" Aeson..= "TerminatedState" diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs index 72bbeca74d..67c54e95d9 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -12,6 +13,8 @@ module Ouroboros.Network.PeerSelection.PeerSharing.Codec import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR import Codec.Serialise (Serialise (..)) +import Data.Aeson qualified as Aeson +import GHC.Generics import Network.Socket (PortNumber, SockAddr (..)) @@ -72,7 +75,7 @@ decodeRemoteAddress = do -- newtype RemoteAddressEncoding addr = RemoteAddressEncoding { getRemoteAddressEncoding :: addr } - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) -- | This instance is used by `LocalStateQuery` mini-protocol codec in -- `ouroboros-consensus-diffusion`. @@ -80,3 +83,7 @@ newtype RemoteAddressEncoding addr = instance Serialise (RemoteAddressEncoding SockAddr) where encode = encodeRemoteAddress . getRemoteAddressEncoding decode = RemoteAddressEncoding <$> decodeRemoteAddress + +instance Aeson.ToJSON (RemoteAddressEncoding SockAddr) where + toJSON (RemoteAddressEncoding addr) = Aeson.toJSON (show addr) + toEncoding (RemoteAddressEncoding addr) = Aeson.toEncoding (show addr) diff --git a/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs b/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs index 1c145e6bc6..6698f8c080 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -25,10 +26,13 @@ import Codec.CBOR.Encoding import Codec.Serialise (Serialise) import Codec.Serialise.Class (decode, encode) import Control.Monad (replicateM) +import Data.Aeson qualified as Aeson import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set +import Data.String (fromString) +import GHC.Generics import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Public @@ -44,7 +48,7 @@ data ConnectionManagerState peeraddr = ConnectionManagerState { registeredOutboundConnections :: Set peeraddr -- ^ set of outbound connections in `ReserverdOutboundSt` state. } - deriving (Eq, Show) + deriving (Eq, Show, Generic) -- | Map 'ConnectionManagerState' -- @@ -64,6 +68,11 @@ mapConnectionManagerStateMonotonic registeredOutboundConnections = Set.mapMonotonic fn registeredOutboundConnections } +instance Aeson.ToJSON peeraddr => Aeson.ToJSON (ConnectionManagerState peeraddr) where + toEncoding ConnectionManagerState { connectionMap, registeredOutboundConnections } = + Aeson.pairs $ + fromString "connectionMap" Aeson..= connectionMap + <> fromString "registeredOutboundConnections" Aeson..= registeredOutboundConnections data InboundState peeraddr = InboundState { remoteHotSet :: !(Set (ConnectionId peeraddr)), @@ -71,7 +80,20 @@ data InboundState peeraddr = InboundState { remoteColdSet :: !(Set (ConnectionId peeraddr)), remoteIdleSet :: !(Set (ConnectionId peeraddr)) } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Aeson.ToJSON peeraddr => Aeson.ToJSON (InboundState peeraddr) where + toEncoding InboundState { + remoteHotSet, + remoteWarmSet, + remoteColdSet, + remoteIdleSet + } = + Aeson.pairs $ + fromString "remoteHotSet" Aeson..= remoteHotSet + <> fromString "remoteWarmSet" Aeson..= remoteWarmSet + <> fromString "remoteColdSet" Aeson..= remoteColdSet + <> fromString "remoteIdleSet" Aeson..= remoteIdleSet mapInboundStateMonotonic :: (peeraddr -> peeraddr') @@ -106,7 +128,18 @@ data OutboundState peeraddr = OutboundState { warmPeers :: Set peeraddr, hotPeers :: Set peeraddr } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Aeson.ToJSON peeraddr => Aeson.ToJSON (OutboundState peeraddr) where + toEncoding OutboundState { + hotPeers, + warmPeers, + coldPeers + } = + Aeson.pairs $ + fromString "hotPeers" Aeson..= hotPeers + <> fromString "warmPeers" Aeson..= warmPeers + <> fromString "coldPeers" Aeson..= coldPeers mapOutboundStateMonotonic :: (peeraddr -> peeraddr') @@ -135,7 +168,18 @@ data NetworkState peeraddr = NetworkState { inboundGovernorState :: InboundState peeraddr, outboundGovernorState :: OutboundState peeraddr } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Aeson.ToJSON peeraddr => Aeson.ToJSON (NetworkState peeraddr) where + toEncoding NetworkState { + connectionManagerState, + inboundGovernorState, + outboundGovernorState + } = + Aeson.pairs $ + fromString "connectionManagerState" Aeson..= connectionManagerState + <> fromString "inboundGovernorState" Aeson..= inboundGovernorState + <> fromString "outboundGovernorState" Aeson..= outboundGovernorState mapNetworkStateMonotonic :: (peeraddr -> peeraddr') From bd2470a28cb06801bbc1567632de8bdc2d50c335 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 7 Jan 2025 11:48:56 +0100 Subject: [PATCH 11/12] ouroboros-network-api: renamed Ouroboros.Network.PeerSelection.PeerSharing.Codec module The `Ouroboros.Network.RemoteAddress.Codec` seems like a better place for it, since its not only `peer-sharing` related. --- ouroboros-network-api/ouroboros-network-api.cabal | 2 +- ouroboros-network-api/src/Ouroboros/Network/PublicState.hs | 3 +-- .../{PeerSelection/PeerSharing => RemoteAddress}/Codec.hs | 2 +- ouroboros-network-protocols/cddl/Main.hs | 4 ++-- .../Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs | 4 ++-- 5 files changed, 7 insertions(+), 8 deletions(-) rename ouroboros-network-api/src/Ouroboros/Network/{PeerSelection/PeerSharing => RemoteAddress}/Codec.hs (98%) diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index 5f5572bb62..0fb0e77996 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -47,11 +47,11 @@ library Ouroboros.Network.PeerSelection.PeerAdvertise Ouroboros.Network.PeerSelection.PeerMetric.Type Ouroboros.Network.PeerSelection.PeerSharing - Ouroboros.Network.PeerSelection.PeerSharing.Codec Ouroboros.Network.PeerSelection.RelayAccessPoint Ouroboros.Network.Point Ouroboros.Network.Protocol.Limits Ouroboros.Network.PublicState + Ouroboros.Network.RemoteAddress.Codec Ouroboros.Network.SizeInBytes Ouroboros.Network.Util.ShowProxy diff --git a/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs b/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs index 6698f8c080..701be16fc5 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PublicState.hs @@ -36,8 +36,7 @@ import GHC.Generics import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Public -import Ouroboros.Network.PeerSelection.PeerSharing.Codec - (RemoteAddressEncoding (..)) +import Ouroboros.Network.RemoteAddress.Codec (RemoteAddressEncoding (..)) data ConnectionManagerState peeraddr = ConnectionManagerState { diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs b/ouroboros-network-api/src/Ouroboros/Network/RemoteAddress/Codec.hs similarity index 98% rename from ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs rename to ouroboros-network-api/src/Ouroboros/Network/RemoteAddress/Codec.hs index 67c54e95d9..b041a56c56 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing/Codec.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/RemoteAddress/Codec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -module Ouroboros.Network.PeerSelection.PeerSharing.Codec +module Ouroboros.Network.RemoteAddress.Codec ( encodePortNumber , decodePortNumber , encodeRemoteAddress diff --git a/ouroboros-network-protocols/cddl/Main.hs b/ouroboros-network-protocols/cddl/Main.hs index 9ea402e2c6..bbde170f8e 100644 --- a/ouroboros-network-protocols/cddl/Main.hs +++ b/ouroboros-network-protocols/cddl/Main.hs @@ -115,8 +115,6 @@ import Ouroboros.Network.Protocol.PeerSharing.Type qualified as PeerSharing import Test.ChainGenerators () import Test.Data.CDDL (Any (..)) -import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, - encodeRemoteAddress) import Ouroboros.Network.Protocol.BlockFetch.Codec.CDDL import Ouroboros.Network.Protocol.ChainSync.Codec.CDDL import Ouroboros.Network.Protocol.LocalStateQuery.Codec.CDDL @@ -124,6 +122,8 @@ import Ouroboros.Network.Protocol.LocalTxMonitor.Codec.CDDL import Ouroboros.Network.Protocol.LocalTxSubmission.Codec.CDDL import Ouroboros.Network.Protocol.PeerSharing.Codec.CDDL import Ouroboros.Network.Protocol.TxSubmission2.Codec.CDDL +import Ouroboros.Network.RemoteAddress.Codec (decodeRemoteAddress, + encodeRemoteAddress) import Test.QuickCheck hiding (Result (..)) import Test.QuickCheck.Instances.ByteString () import Test.Tasty (TestTree, adjustOption, defaultMain, testGroup) diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs index 7892898088..75e6b13dee 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/PeerSharing/Codec/CDDL.hs @@ -5,10 +5,10 @@ import Data.ByteString.Lazy qualified as BL import Network.Socket (SockAddr (..)) import Network.TypedProtocol.Codec import Ouroboros.Network.NodeToNode.Version -import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, - encodeRemoteAddress) import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Type +import Ouroboros.Network.RemoteAddress.Codec (decodeRemoteAddress, + encodeRemoteAddress) peerSharingCodec :: NodeToNodeVersion -> Codec (PeerSharing SockAddr) From fda50a7a26db26e8265ee83be10fa41293b013e0 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 10 Jan 2025 20:13:51 +0100 Subject: [PATCH 12/12] WIP: added TODO --- .../src/Ouroboros/Network/Server/Simple.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs index 05dfd83936..3f06679efc 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs @@ -33,6 +33,8 @@ import Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Socket +-- TODO: should be moved to `ouroboros-network-framework` +-- It is needed in `ekg-forward` and probably wallet too. with :: forall fd addr vNumber vData m a b. ( Alternative (STM m), MonadAsync m,