From 3df63a8c57ca1257f1bc11e4d6a3a5880a2d4302 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 1 Nov 2024 11:04:58 +0100 Subject: [PATCH 1/6] diffusion: removed NonP2P diffusion --- ouroboros-network/ouroboros-network.cabal | 4 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 171 +- .../Network/Diffusion/Node/MiniProtocols.hs | 48 +- .../Diffusion/Testnet/Cardano/Simulation.hs | 146 +- .../Cardano/Network/Diffusion/Handlers.hs | 26 +- .../src/Ouroboros/Network/Diffusion.hs | 1075 ++++++++++-- .../src/Ouroboros/Network/Diffusion/Common.hs | 196 --- .../src/Ouroboros/Network/Diffusion/P2P.hs | 1485 ----------------- .../src/Ouroboros/Network/Diffusion/Types.hs | 699 ++++++++ .../src/Ouroboros/Network/Diffusion/Utils.hs | 2 +- 10 files changed, 1844 insertions(+), 2008 deletions(-) delete mode 100644 ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs delete mode 100644 ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs create mode 100644 ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index bbd9ae99ad1..959920cdca6 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -80,11 +80,9 @@ library Ouroboros.Network.BlockFetch.State Ouroboros.Network.DeltaQ Ouroboros.Network.Diffusion - Ouroboros.Network.Diffusion.Common Ouroboros.Network.Diffusion.Configuration - Ouroboros.Network.Diffusion.NonP2P - Ouroboros.Network.Diffusion.P2P Ouroboros.Network.Diffusion.Policies + Ouroboros.Network.Diffusion.Types Ouroboros.Network.ExitPolicy Ouroboros.Network.KeepAlive Ouroboros.Network.NodeToClient diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs index c919189a06a..fe872cf3d85 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -82,8 +82,7 @@ import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (ChainSelStarvationEndedAt)) import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply) import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) -import Ouroboros.Network.Diffusion.Common qualified as Common -import Ouroboros.Network.Diffusion.P2P qualified as P2P +import Ouroboros.Network.Diffusion qualified as Diff import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) import Ouroboros.Network.Mock.Chain (Chain, toAnchoredFragment, toOldestFirst) import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..), @@ -99,8 +98,8 @@ import Ouroboros.Network.PeerSelection.LedgerPeers (NumberOfPeers) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeersConsensusInterface, LedgerPeersKind, UseLedgerPeers) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) -import Ouroboros.Network.PeerSelection.PeerMetric - (PeerMetricsConfiguration (..), newPeerMetric) +import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, + PeerMetricsConfiguration (..), newPeerMetric) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle) import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) @@ -112,8 +111,6 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore (DNSSemaphore) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, LocalRootConfig, WarmValency) import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI (..)) -import Ouroboros.Network.RethrowPolicy (ErrorCommand (ShutdownNode), - ioErrorRethrowPolicy, mkRethrowPolicy, muxErrorRethrowPolicy) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) @@ -252,17 +249,17 @@ run :: forall extraState extraDebugState extraAPI extraCounters NtNAddr -> m Void) - -> P2P.TracersExtra NtNAddr NtNVersion NtNVersionData - NtCAddr NtCVersion NtCVersionData - ResolverException extraState extraDebugState extraFlags - extraPeers extraCounters m + -> Diff.Tracers NtNAddr NtNVersion NtNVersionData + NtCAddr NtCVersion NtCVersionData + ResolverException extraState extraDebugState extraFlags + extraPeers extraCounters m -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) -> m Void run blockGeneratorArgs limits ni na emptyExtraState emptyExtraCounters extraPeersAPI psArgs psToExtraCounters toExtraPeers requestPublicRootPeers peerChurnGovernor - tracersExtra tracerBlockFetch = + tracers tracerBlockFetch = Node.withNodeKernelThread blockGeneratorArgs $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) @@ -270,16 +267,16 @@ run blockGeneratorArgs limits ni na peerMetrics <- newPeerMetric PeerMetricsConfiguration { maxEntriesToTrack = 180 } let -- diffusion interfaces - interfaces :: P2P.Interfaces (NtNFD m) NtNAddr NtNVersion NtNVersionData - (NtCFD m) NtCAddr NtCVersion NtCVersionData - resolver ResolverException extraState extraFlags extraPeers extraAPI m - interfaces = P2P.Interfaces - { P2P.diNtnSnocket = iNtnSnocket ni - , P2P.diNtnBearer = iNtnBearer ni - , P2P.diNtnConfigureSocket = \_ _ -> return () - , P2P.diNtnConfigureSystemdSocket + interfaces :: Diff.Interfaces (NtNFD m) NtNAddr NtNVersion NtNVersionData + (NtCFD m) NtCAddr NtCVersion NtCVersionData + resolver ResolverException extraState extraFlags extraPeers extraAPI m + interfaces = Diff.Interfaces + { Diff.diNtnSnocket = iNtnSnocket ni + , Diff.diNtnBearer = iNtnBearer ni + , Diff.diNtnConfigureSocket = \_ _ -> return () + , Diff.diNtnConfigureSystemdSocket = \_ _ -> return () - , P2P.diNtnHandshakeArguments = + , Diff.diNtnHandshakeArguments = HandshakeArguments { haHandshakeTracer = nullTracer , haHandshakeCodec = unversionedHandshakeCodec @@ -288,16 +285,16 @@ run blockGeneratorArgs limits ni na , haQueryVersion = const False , haTimeLimits = timeLimitsHandshake } - , P2P.diNtnAddressType = ntnAddressType - , P2P.diNtnDataFlow = \NtNVersionData { ntnDiffusionMode } -> + , Diff.diNtnAddressType = ntnAddressType + , Diff.diNtnDataFlow = \NtNVersionData { ntnDiffusionMode } -> case ntnDiffusionMode of InitiatorOnlyDiffusionMode -> Unidirectional InitiatorAndResponderDiffusionMode -> Duplex - , P2P.diNtnPeerSharing = ntnPeerSharing - , P2P.diNtnToPeerAddr = \a b -> TestAddress (Node.IPAddr a b) - , P2P.diNtcSnocket = iNtcSnocket ni - , P2P.diNtcBearer = iNtcBearer ni - , P2P.diNtcHandshakeArguments = + , Diff.diNtnPeerSharing = ntnPeerSharing + , Diff.diNtnToPeerAddr = \a b -> TestAddress (Node.IPAddr a b) + , Diff.diNtcSnocket = iNtcSnocket ni + , Diff.diNtcBearer = iNtcBearer ni + , Diff.diNtcHandshakeArguments = HandshakeArguments { haHandshakeTracer = nullTracer , haHandshakeCodec = unversionedHandshakeCodec @@ -306,44 +303,31 @@ run blockGeneratorArgs limits ni na , haQueryVersion = const False , haTimeLimits = noTimeLimitsHandshake } - , P2P.diNtcGetFileDescriptor = \_ -> pure invalidFileDescriptor - , P2P.diRng = diffStgGen - , P2P.diInstallSigUSR1Handler = \_ _ _ -> pure () - , P2P.diDnsActions = const (mockDNSActions + , Diff.diNtcGetFileDescriptor = \_ -> pure invalidFileDescriptor + , Diff.diRng = diffStgGen + , Diff.diInstallSigUSR1Handler = \_ _ _ -> pure () + , Diff.diDnsActions = const (mockDNSActions (iDomainMap ni) dnsTimeoutScriptVar dnsLookupDelayScriptVar) - , P2P.diUpdateVersionData = \versionData diffusionMode -> + , Diff.diUpdateVersionData = \versionData diffusionMode -> versionData { ntnDiffusionMode = diffusionMode } - , P2P.diConnStateIdSupply = iConnStateIdSupply ni + , Diff.diConnStateIdSupply = iConnStateIdSupply ni } - appsExtra :: P2P.ApplicationsExtra NtNAddr m () - appsExtra = P2P.ApplicationsExtra - { -- TODO: simulation errors should be critical - P2P.daRethrowPolicy = - muxErrorRethrowPolicy - <> ioErrorRethrowPolicy - - -- we are not using local connections, so we can make all the - -- errors fatal. - , P2P.daLocalRethrowPolicy = - mkRethrowPolicy - (\ _ (_ :: SomeException) -> ShutdownNode) - , P2P.daPeerMetrics = peerMetrics - -- fetch mode is not used (no block-fetch mini-protocol) - , P2P.daReturnPolicy = \_ -> config_REPROMOTE_DELAY - , P2P.daPeerSharingRegistry = nkPeerSharingRegistry nodeKernel - } - - let apps = Node.applications (aDebugTracer na) nodeKernel Node.cborCodecs limits appArgs blockHeader + apps = Node.applications + (aDebugTracer na) + nodeKernel + Node.cborCodecs + limits + (appArgs peerMetrics) + blockHeader withAsync - (P2P.runM interfaces - Common.nullTracers - tracersExtra - (mkArgs (nkPublicPeerSelectionVar nodeKernel)) - argsExtra apps appsExtra) + (Diff.runM interfaces + tracers + (mkArgs (nkPublicPeerSelectionVar nodeKernel)) + apps) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> wait diffusionThread @@ -450,48 +434,46 @@ run blockGeneratorArgs limits ni na decodeData _ _ = Left (Text.pack "unversionedDataCodec: unexpected term") mkArgs :: StrictTVar m (PublicPeerSelectionState NtNAddr) - -> Common.Arguments m (NtNFD m) NtNAddr (NtCFD m) NtCAddr - mkArgs daPublicPeerSelectionVar = Common.Arguments - { Common.daIPv4Address = Right <$> (ntnToIPv4 . aIPAddress) na - , Common.daIPv6Address = Right <$> (ntnToIPv6 . aIPAddress) na - , Common.daLocalAddress = Nothing - , Common.daAcceptedConnectionsLimit - = aAcceptedLimits na - , Common.daMode = aDiffusionMode na - , Common.daPublicPeerSelectionVar - } - - argsExtra :: P2P.ArgumentsExtra + -> Diff.Arguments extraState extraDebugState extraFlags extraPeers extraAPI extraChurnArgs extraCounters exception - NtNAddr NtCAddr resolver resolverError m - argsExtra = P2P.ArgumentsExtra - { P2P.daPeerSelectionTargets = aPeerTargets na - , P2P.daReadLocalRootPeers = aReadLocalRootPeers na - , P2P.daReadPublicRootPeers = aReadPublicRootPeers na - , P2P.daOwnPeerSharing = aOwnPeerSharing na - , P2P.daReadUseLedgerPeers = aReadUseLedgerPeers na - , P2P.daProtocolIdleTimeout = aProtocolIdleTimeout na - , P2P.daTimeWaitTimeout = aTimeWaitTimeout na - , P2P.daDeadlineChurnInterval = 3300 - , P2P.daBulkChurnInterval = 300 - , P2P.daReadLedgerPeerSnapshot = pure Nothing -- ^ tested independently - , P2P.daEmptyExtraState = emptyExtraState - , P2P.daEmptyExtraCounters = emptyExtraCounters - , P2P.daExtraPeersAPI = extraPeersAPI - , P2P.daExtraChurnArgs = aExtraChurnArgs na - , P2P.daToExtraPeers = toExtraPeers - , P2P.daRequestPublicRootPeers = Just requestPublicRootPeers - , P2P.daPeerChurnGovernor = peerChurnGovernor - , P2P.daPeerSelectionGovernorArgs = psArgs - , P2P.daPeerSelectionStateToExtraCounters = psToExtraCounters - , P2P.daMuxForkPolicy = noBindForkPolicy - , P2P.daLocalMuxForkPolicy = noBindForkPolicy + resolver resolverError + m (NtNFD m) NtNAddr (NtCFD m) NtCAddr + mkArgs daPublicPeerSelectionVar = 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.daPeerSelectionTargets = aPeerTargets na + , Diff.daReadLocalRootPeers = aReadLocalRootPeers na + , Diff.daReadPublicRootPeers = aReadPublicRootPeers na + , Diff.daOwnPeerSharing = aOwnPeerSharing na + , Diff.daReadUseLedgerPeers = aReadUseLedgerPeers na + , Diff.daProtocolIdleTimeout = aProtocolIdleTimeout na + , Diff.daTimeWaitTimeout = aTimeWaitTimeout na + , Diff.daDeadlineChurnInterval = 3300 + , Diff.daBulkChurnInterval = 300 + , Diff.daReadLedgerPeerSnapshot = pure Nothing -- ^ tested independently + , Diff.daEmptyExtraState = emptyExtraState + , Diff.daEmptyExtraCounters = emptyExtraCounters + , Diff.daExtraPeersAPI = extraPeersAPI + , Diff.daExtraChurnArgs = aExtraChurnArgs na + , Diff.daToExtraPeers = toExtraPeers + , Diff.daRequestPublicRootPeers = Just requestPublicRootPeers + , Diff.daPeerChurnGovernor = peerChurnGovernor + , Diff.daPeerSelectionGovernorArgs = psArgs + , Diff.daPeerSelectionStateToExtraCounters = psToExtraCounters + , Diff.daMuxForkPolicy = noBindForkPolicy + , Diff.daLocalMuxForkPolicy = noBindForkPolicy } - appArgs :: Node.AppArgs extraAPI BlockHeader Block m - appArgs = Node.AppArgs + appArgs :: PeerMetrics m NtNAddr + -> Node.AppArgs extraAPI BlockHeader Block m + appArgs peerMetrics = Node.AppArgs { Node.aaLedgerPeersConsensusInterface = iLedgerPeersConsensusInterface ni , Node.aaKeepAliveStdGen = keepAliveStdGen @@ -501,6 +483,7 @@ run blockGeneratorArgs limits ni na , Node.aaShouldChainSyncExit = aShouldChainSyncExit na , Node.aaChainSyncEarlyExit = aChainSyncEarlyExit na , Node.aaOwnPeerSharing = aOwnPeerSharing na + , Node.aaPeerMetrics = peerMetrics } --- Utils diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index ce2e9c470b1..9473b1ef81f 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -15,6 +15,8 @@ module Test.Ouroboros.Network.Diffusion.Node.MiniProtocols , LimitsAndTimeouts (..) , AppArgs (..) , applications + -- * configuration constants + , config_REPROMOTE_DELAY ) where import Control.Applicative (Alternative) @@ -72,8 +74,9 @@ import Ouroboros.Network.Block (HasHeader, HeaderHash, Point) import Ouroboros.Network.Block qualified as Block import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage (ControlMessage (..)) -import Ouroboros.Network.Diffusion.Common qualified as Common +import Ouroboros.Network.Diffusion.Types qualified as Diff import Ouroboros.Network.Driver.Limits +import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) import Ouroboros.Network.KeepAlive import Ouroboros.Network.Mock.Chain qualified as Chain import Ouroboros.Network.Mock.ConcreteBlock @@ -84,6 +87,7 @@ import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, peerSharingMiniProtocolNum) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.LedgerPeers +import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) import Ouroboros.Network.PeerSelection.PeerSharing qualified as PSTypes import Ouroboros.Network.PeerSharing (PeerSharingAPI, bracketPeerSharingClient, peerSharingClient, peerSharingServer) @@ -91,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.RethrowPolicy import Ouroboros.Network.Util.ShowProxy import Test.Ouroboros.Network.Diffusion.Node.Kernel @@ -203,6 +208,8 @@ data AppArgs extraAPI header block m = AppArgs , aaChainSyncEarlyExit :: Bool , aaOwnPeerSharing :: PSTypes.PeerSharing + , aaPeerMetrics + :: PeerMetrics m NtNAddr } @@ -233,9 +240,9 @@ applications :: forall extraAPI block header s m. -> LimitsAndTimeouts header block -> AppArgs extraAPI header block m -> (block -> header) - -> Common.Applications NtNAddr NtNVersion NtNVersionData - NtCAddr NtCVersion NtCVersionData - extraAPI m () + -> Diff.Applications NtNAddr NtNVersion NtNVersionData + NtCAddr NtCVersion NtCVersionData + extraAPI m () applications debugTracer nodeKernel Codecs { chainSyncCodec, blockFetchCodec , keepAliveCodec, pingPongCodec @@ -251,23 +258,39 @@ applications debugTracer nodeKernel , aaShouldChainSyncExit , aaChainSyncEarlyExit , aaOwnPeerSharing + , aaPeerMetrics } toHeader = - Common.Applications - { Common.daApplicationInitiatorMode = + Diff.Applications + { Diff.daApplicationInitiatorMode = simpleSingletonVersions UnversionedProtocol (NtNVersionData InitiatorOnlyDiffusionMode aaOwnPeerSharing) (\NtNVersionData {ntnPeerSharing} -> initiatorApp ntnPeerSharing) - , Common.daApplicationInitiatorResponderMode = + , Diff.daApplicationInitiatorResponderMode = simpleSingletonVersions UnversionedProtocol (NtNVersionData aaDiffusionMode aaOwnPeerSharing) (\NtNVersionData {ntnPeerSharing} -> initiatorAndResponderApp ntnPeerSharing) - , Common.daLocalResponderApplication = + , Diff.daLocalResponderApplication = simpleSingletonVersions UnversionedProtocol UnversionedProtocolData (\_ -> localResponderApp) - , Common.daLedgerPeersCtx = + , Diff.daLedgerPeersCtx = aaLedgerPeersConsensusInterface + + , Diff.daRethrowPolicy = + muxErrorRethrowPolicy + <> ioErrorRethrowPolicy + + -- we are not using local connections, so we can make all the + -- errors fatal. + , Diff.daLocalRethrowPolicy = + mkRethrowPolicy + (\ _ (_ :: SomeException) -> ShutdownNode) + , Diff.daPeerMetrics = aaPeerMetrics + -- fetch mode is not used (no block-fetch mini-protocol) + , Diff.daBlockFetchMode = pure (PraosFetchMode FetchModeDeadline) + , Diff.daReturnPolicy = \_ -> config_REPROMOTE_DELAY + , Diff.daPeerSharingRegistry = nkPeerSharingRegistry nodeKernel } where initiatorApp @@ -608,3 +631,10 @@ applications debugTracer nodeKernel instance ShowProxy PingPong where showProxy Proxy = "PingPong" + +-- +-- Constants +-- + +config_REPROMOTE_DELAY :: RepromoteDelay +config_REPROMOTE_DELAY = 10 diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 4cc3941b7e3..4975a39c8a9 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -101,7 +101,7 @@ import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Core qualified as CM import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (AbstractTransitionTrace) -import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P +import Ouroboros.Network.Diffusion qualified as Diff import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..), ProtocolTimeLimits (..)) import Ouroboros.Network.Handshake.Acceptable (Acceptable (acceptableVersion)) @@ -1245,10 +1245,10 @@ diffusionSimulation , Node.aExtraChurnArgs = cardanoChurnArgs } - tracersExtraAddr = tracersExtra addr + tracers = mkTracers addr requestPublicRootPeers' = - requestPublicRootPeers (Diff.P2P.dtTracePublicRootPeersTracer tracersExtraAddr) + requestPublicRootPeers (Diff.dtTracePublicRootPeersTracer tracers) (Cardano.readUseBootstrapPeers cardanoExtraArgs) (pure TooOld) readPublicRootPeers @@ -1267,7 +1267,7 @@ diffusionSimulation (flip Cardano.ExtraPeers Set.empty) requestPublicRootPeers' peerChurnGovernor - tracersExtraAddr + tracers ( contramap (DiffusionFetchTrace . (\(TraceLabelPeer _ a) -> a)) . tracerWithName addr . tracerWithTime @@ -1298,84 +1298,84 @@ diffusionSimulation . tracerWithTime $ nodeTracer - tracersExtra + mkTracers :: NtNAddr - -> Diff.P2P.TracersExtra NtNAddr NtNVersion NtNVersionData - NtCAddr NtCVersion NtCVersionData - SomeException Cardano.ExtraState - Cardano.ExtraState PeerTrustable - (Cardano.ExtraPeers NtNAddr) - (Cardano.ExtraPeerSelectionSetsWithSizes NtNAddr) m - tracersExtra ntnAddr = - Diff.P2P.TracersExtra { - Diff.P2P.dtTraceLocalRootPeersTracer = contramap - DiffusionLocalRootPeerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtTracePublicRootPeersTracer = contramap - DiffusionPublicRootPeerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtTraceLedgerPeersTracer = contramap - DiffusionLedgerPeersTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtTracePeerSelectionTracer = contramap - DiffusionPeerSelectionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtDebugPeerSelectionInitiatorTracer = contramap - DiffusionDebugPeerSelectionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtDebugPeerSelectionInitiatorResponderTracer + -> Diff.Tracers NtNAddr NtNVersion NtNVersionData + NtCAddr NtCVersion NtCVersionData + SomeException Cardano.ExtraState + Cardano.ExtraState PeerTrustable + (Cardano.ExtraPeers NtNAddr) + (Cardano.ExtraPeerSelectionSetsWithSizes NtNAddr) m + mkTracers ntnAddr = + Diff.nullTracers { + Diff.dtTraceLocalRootPeersTracer = contramap + DiffusionLocalRootPeerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtTracePublicRootPeersTracer = contramap + DiffusionPublicRootPeerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtTraceLedgerPeersTracer = contramap + DiffusionLedgerPeersTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtTracePeerSelectionTracer = contramap + DiffusionPeerSelectionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtDebugPeerSelectionInitiatorTracer = contramap + DiffusionDebugPeerSelectionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtDebugPeerSelectionInitiatorResponderTracer = contramap DiffusionDebugPeerSelectionTrace . tracerWithName ntnAddr . tracerWithTime $ nodeTracer - , Diff.P2P.dtTracePeerSelectionCounters = nullTracer - , Diff.P2P.dtTraceChurnCounters = nullTracer - , Diff.P2P.dtPeerSelectionActionsTracer = contramap - DiffusionPeerSelectionActionsTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtConnectionManagerTracer = contramap - DiffusionConnectionManagerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtConnectionManagerTransitionTracer = contramap - DiffusionConnectionManagerTransitionTrace - . tracerWithName ntnAddr - . tracerWithTime + , Diff.dtTracePeerSelectionCounters = nullTracer + , Diff.dtTraceChurnCounters = nullTracer + , Diff.dtPeerSelectionActionsTracer = contramap + DiffusionPeerSelectionActionsTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtConnectionManagerTracer = contramap + DiffusionConnectionManagerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtConnectionManagerTransitionTracer = contramap + DiffusionConnectionManagerTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime -- note: we have two ways getting transition trace: -- * through `traceTVar` installed in `newMutableConnState` -- * the `dtConnectionManagerTransitionTracer` $ nodeTracer - , Diff.P2P.dtServerTracer = contramap - DiffusionServerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtInboundGovernorTracer = contramap - DiffusionInboundGovernorTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtInboundGovernorTransitionTracer = contramap - DiffusionInboundGovernorTransitionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diff.P2P.dtLocalConnectionManagerTracer = nullTracer - , Diff.P2P.dtLocalServerTracer = nullTracer - , Diff.P2P.dtLocalInboundGovernorTracer = nullTracer + , Diff.dtServerTracer = contramap + DiffusionServerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtInboundGovernorTracer = contramap + DiffusionInboundGovernorTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtInboundGovernorTransitionTracer = contramap + DiffusionInboundGovernorTransitionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer + , Diff.dtLocalConnectionManagerTracer = nullTracer + , Diff.dtLocalServerTracer = nullTracer + , Diff.dtLocalInboundGovernorTracer = nullTracer } diff --git a/ouroboros-network/src/Ouroboros/Cardano/Network/Diffusion/Handlers.hs b/ouroboros-network/src/Ouroboros/Cardano/Network/Diffusion/Handlers.hs index 084cb5248bd..fcf0fd4c288 100644 --- a/ouroboros-network/src/Ouroboros/Cardano/Network/Diffusion/Handlers.hs +++ b/ouroboros-network/src/Ouroboros/Cardano/Network/Diffusion/Handlers.hs @@ -11,7 +11,7 @@ import Cardano.Network.Types (LedgerStateJudgement) import Control.Concurrent.Class.MonadSTM.Strict import Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Diffusion.P2P (TracersExtra (..)) +import Ouroboros.Network.Diffusion.Types (Tracers (..)) import Ouroboros.Network.PeerSelection.Governor import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) import Ouroboros.Network.PeerSelection.PeerMetric @@ -28,12 +28,12 @@ import System.Posix.Signals qualified as Signals #ifdef POSIX sigUSR1Handler :: Ord ntnAddr - => TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError extraState - Cardano.DebugPeerSelectionState - extraFlags extraPeers extraCounters - IO + => Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError extraState + Cardano.DebugPeerSelectionState + extraFlags extraPeers extraCounters + IO -> STM IO UseLedgerPeers -> PeerSharing -> STM IO UseBootstrapPeers @@ -76,12 +76,12 @@ sigUSR1Handler tracersExtra getUseLedgerPeers ownPeerSharing getBootstrapPeers return () #else sigUSR1Handler - :: TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError extraState - Cardano.DebugPeerSelectionState - extraFlags extraPeers extraCounters - IO + :: Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError extraState + Cardano.DebugPeerSelectionState + extraFlags extraPeers extraCounters + IO -> STM IO UseLedgerPeers -> PeerSharing -> UseBootstrapPeers diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 36952f5965e..9ca67d80bf1 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -1,154 +1,961 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | This module is expected to be imported qualified (it will clash +-- with the "Ouroboros.Network.Diffusion.NonP2P"). +-- module Ouroboros.Network.Diffusion - ( -- * Common API - P2P (..) - , P2PDecision (..) - , ExtraTracers (..) - , ArgumentsExtra (..) - , Applications (..) - , ApplicationsExtra (..) - -- * Run data diffusion + ( Tracers (..) + , nullTracers + , Arguments (..) , run + , Interfaces (..) + , runM + -- * Re-exports + , AbstractTransitionTrace + , IG.RemoteTransitionTrace ) where -import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar) -import Control.Exception (Exception, IOException) -import Data.Functor (void) + +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (IOException) +import Control.Monad.Class.MonadAsync (Async, MonadAsync) +import Control.Monad.Class.MonadAsync qualified as Async +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +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.Void (Void) +import System.Exit (ExitCode) +import System.Random (StdGen, newStdGen, split) + import Network.DNS (Resolver) +import Network.Mux qualified as Mx import Network.Socket (Socket) -import Ouroboros.Network.Diffusion.Common (Applications (..), Arguments, - Tracers) -import Ouroboros.Network.Diffusion.NonP2P qualified as NonP2P -import Ouroboros.Network.Diffusion.P2P qualified as P2P -import Ouroboros.Network.NodeToClient (LocalAddress, LocalSocket, - NodeToClientVersion, NodeToClientVersionData) -import Ouroboros.Network.NodeToNode (NodeToNodeVersion, NodeToNodeVersionData, - RemoteAddress) -import Ouroboros.Network.PeerSelection.Governor.Types (PeerSelectionState) -import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) - --- | Promoted data types. --- -data P2P = P2P -- ^ General P2P mode. Can be instantiated with custom - -- data types - | NonP2P -- ^ Cardano non-P2P mode. Deprecated +import Network.Socket qualified as Socket --- | Auxiliary type to define arbitrary decision types based on type level --- P2P --- -data P2PDecision (p2p :: P2P) a b where - P2PDecision :: a - -> P2PDecision 'P2P a b - NonP2PDecision :: b - -> P2PDecision 'NonP2P a b +import Ouroboros.Network.ConnectionHandler +import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.InformationChannel + (newInformationChannel) +import Ouroboros.Network.ConnectionManager.State qualified as CM +import Ouroboros.Network.ConnectionManager.Types +import Ouroboros.Network.Context (ExpandedInitiatorContext) +import Ouroboros.Network.Diffusion.Configuration +import Ouroboros.Network.Diffusion.Policies (simplePeerSelectionPolicy) +import Ouroboros.Network.Diffusion.Policies qualified as Diffusion.Policies +import Ouroboros.Network.Diffusion.Types +import Ouroboros.Network.Diffusion.Utils +import Ouroboros.Network.ExitPolicy +import Ouroboros.Network.InboundGovernor qualified as IG +import Ouroboros.Network.IOManager +import Ouroboros.Network.Mux hiding (MiniProtocol (..)) +import Ouroboros.Network.MuxMode +import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), + NodeToClientVersionData) +import Ouroboros.Network.NodeToClient qualified as NodeToClient +import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..), + NodeToNodeVersionData (..), RemoteAddress) +import Ouroboros.Network.NodeToNode qualified as NodeToNode +import Ouroboros.Network.PeerSelection.Churn (PeerChurnArgs (..)) +import Ouroboros.Network.PeerSelection.Governor qualified as Governor +import Ouroboros.Network.PeerSelection.Governor.Types hiding (peerSharing) +import Ouroboros.Network.PeerSelection.LedgerPeers (WithLedgerPeersArgs (..)) +import Ouroboros.Network.PeerSelection.PeerMetric +import Ouroboros.Network.PeerSelection.PeerSelectionActions +import Ouroboros.Network.PeerSelection.PeerSelectionActions qualified as Ouroboros +import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, + PeerStateActionsArguments (..), pchPeerSharing, withPeerStateActions) +import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions + (DNSLookupType (..), ioDNSActions) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore + (newLedgerAndPublicRootDNSSemaphore) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers +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.RethrowPolicy +import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Snocket (LocalAddress, LocalSocket (..), + localSocketFileDescriptor, makeLocalBearer, makeSocketBearer) +import Ouroboros.Network.Snocket qualified as Snocket +import Ouroboros.Network.Socket (configureSocket, configureSystemdSocket) + + +socketAddressType :: Socket.SockAddr -> Maybe AddressType +socketAddressType Socket.SockAddrInet {} = Just IPv4Address +socketAddressType Socket.SockAddrInet6 {} = Just IPv6Address +socketAddressType Socket.SockAddrUnix {} = Nothing + + +runM + :: forall m ntnFd ntnAddr ntnVersion ntnVersionData + ntcFd ntcAddr ntcVersion ntcVersionData + resolver resolverError exception a + extraState extraDebugState extraPeers + extraAPI extraFlags extraChurnArgs extraCounters . + + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m + , MonadEvaluate m + , MonadFix m + , MonadFork m + , MonadLabelledSTM m + , MonadTraceSTM m + , MonadMask m + , MonadThrow (STM m) + , MonadTime m + , MonadTimer m + , MonadMVar m + , Typeable ntnAddr + , Ord ntnAddr + , Show ntnAddr + , Hashable ntnAddr + , Typeable ntnVersion + , Ord ntnVersion + , Show ntnVersion + , Show ntnVersionData + , Typeable ntcAddr + , Ord ntcAddr + , Show ntcAddr + , Ord ntcVersion + , Exception resolverError + , Monoid extraPeers + , Eq extraFlags + , Eq extraCounters + , Exception exception + ) + => -- | interfaces + Interfaces ntnFd ntnAddr ntnVersion ntnVersionData + ntcFd ntcAddr ntcVersion ntcVersionData + resolver resolverError + extraState extraFlags extraPeers extraAPI m + -> -- | tracers + Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError + extraState extraDebugState extraFlags + extraPeers extraCounters m + -> -- | configuration + Arguments extraState extraDebugState extraFlags extraPeers + extraAPI extraChurnArgs extraCounters exception + resolver resolverError + m ntnFd ntnAddr ntcFd ntcAddr + + -> -- | protocol handlers + Applications ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + extraAPI m a + -> m Void +runM Interfaces + { diNtnSnocket + , diNtnBearer + , diNtnConfigureSocket + , diNtnConfigureSystemdSocket + , diNtnHandshakeArguments + , diNtnAddressType + , diNtnDataFlow + , diNtnPeerSharing + , diNtnToPeerAddr + , diNtcSnocket + , diNtcBearer + , diNtcHandshakeArguments + , diNtcGetFileDescriptor + , diRng + , diInstallSigUSR1Handler + , diDnsActions + , diUpdateVersionData + , diConnStateIdSupply + } + Tracers + { dtMuxTracer + , dtLocalMuxTracer + , dtDiffusionTracer = tracer + , dtTracePeerSelectionTracer + , dtTraceChurnCounters + , dtDebugPeerSelectionInitiatorTracer + , dtDebugPeerSelectionInitiatorResponderTracer + , dtTracePeerSelectionCounters + , dtPeerSelectionActionsTracer + , dtTraceLocalRootPeersTracer + , dtTracePublicRootPeersTracer + , dtTraceLedgerPeersTracer + , dtConnectionManagerTracer + , dtConnectionManagerTransitionTracer + , dtServerTracer + , dtInboundGovernorTracer + , dtInboundGovernorTransitionTracer + , dtLocalConnectionManagerTracer + , dtLocalServerTracer + , dtLocalInboundGovernorTracer + } + Arguments + { daIPv4Address + , daIPv6Address + , daLocalAddress + , daAcceptedConnectionsLimit + , daMode = diffusionMode + , daPublicPeerSelectionVar + , daPeerSelectionTargets + , daReadLocalRootPeers + , daReadPublicRootPeers + , daOwnPeerSharing + , daReadUseLedgerPeers + , daProtocolIdleTimeout + , daTimeWaitTimeout + , daDeadlineChurnInterval + , daBulkChurnInterval + , daReadLedgerPeerSnapshot + , daEmptyExtraState + , daEmptyExtraCounters + , daExtraPeersAPI + , daPeerSelectionGovernorArgs + , daPeerSelectionStateToExtraCounters + , daPeerChurnGovernor + , daToExtraPeers + , daRequestPublicRootPeers + , daExtraChurnArgs + , daMuxForkPolicy + , daLocalMuxForkPolicy + } + Applications + { daApplicationInitiatorMode + , daApplicationInitiatorResponderMode + , daLocalResponderApplication + , daLedgerPeersCtx + , daRethrowPolicy + , daLocalRethrowPolicy + , daReturnPolicy + , daPeerMetrics + , daPeerSharingRegistry + } + = do + -- Thread to which 'RethrowPolicy' will throw fatal exceptions. + mainThreadId <- myThreadId + + -- 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)) + ) + + where + (ledgerPeersRng, rng1) = split diRng + (policyRng, rng2) = split rng1 + (churnRng, rng3) = split rng2 + (fuzzRng, rng4) = split rng3 + (cmLocalStdGen, rng5) = split rng4 + (cmStdGen1, cmStdGen2) = split rng5 + + + mkInboundPeersMap :: IG.PublicState ntnAddr ntnVersionData + -> Map ntnAddr PeerSharing + mkInboundPeersMap + IG.PublicState { IG.inboundDuplexPeers } + = + Map.map diNtnPeerSharing inboundDuplexPeers + + -- TODO: this policy should also be used in `PeerStateActions` and + -- `InboundGovernor` (when creating or accepting connections) + rethrowPolicy = + -- Only the 'IOManagerError's are fatal, all the other exceptions in the + -- networking code will only shutdown the bearer (see 'ShutdownPeer' why + -- this is so). + RethrowPolicy (\_ctx err -> + case fromException err of + Just (_ :: IOManagerError) -> ShutdownNode + Nothing -> mempty) + <> + -- IOError rethrow-policy + -- + -- After a critical bug, we decided that `IOError` policy should only + -- kill the connection which thrown it. `IOError`s are not propagated. + -- There's a risk that one could arm an attack if one discovers + -- a mechanism to trigger fatal `IOError`s, e.g. through a kernel bug. + -- + -- It is responsibility for an SPO to monitor the node if it is making + -- progress and have enough resources to do so, e.g. if it has enough + -- memory, file descriptors. + -- + -- The `ouroboros-network` guarantees running on a fixed number of file + -- descriptors given a topology file, see + -- https://github.com/IntersectMBO/ouroboros-network/issues/4585#issuecomment-1591777447 + -- There's also a calculation for `ouroboros-consensus`, see + -- https://github.com/IntersectMBO/ouroboros-consensus/issues/20#issuecomment-1514554680 + -- File descriptors could be drained by the tracing system in + -- `cardano-node` (such a bug existed), or even an external process. + -- + RethrowPolicy (\_ctx err -> + case fromException err :: Maybe IOException of + Just {} -> mempty + Nothing -> mempty) + <> + RethrowPolicy (\ctx err -> case (ctx, fromException err) of + (OutboundError, Just Mx.UnknownMiniProtocol {}) + -> ShutdownPeer + _ -> mempty) + + + -- | 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 + localInbInfoChannel <- newInformationChannel + + let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 + + localConnectionHandler :: NodeToClientConnectionHandler + ntcFd ntcAddr ntcVersion ntcVersionData m + localConnectionHandler = + makeConnectionHandler + dtLocalMuxTracer + SingResponderMode + daLocalMuxForkPolicy + diNtcHandshakeArguments + ( ( \ (OuroborosApplication apps) + -> TemperatureBundle + (WithHot apps) + (WithWarm []) + (WithEstablished []) + ) <$> daLocalResponderApplication ) + (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) + + localConnectionManagerArguments + :: NodeToClientConnectionManagerArguments + ntcFd ntcAddr ntcVersion ntcVersionData m + localConnectionManagerArguments = + CM.Arguments { + CM.tracer = dtLocalConnectionManagerTracer, + CM.trTracer = nullTracer, -- TODO: issue #3320 + CM.muxTracer = dtLocalMuxTracer, + CM.ipv4Address = Nothing, + CM.ipv6Address = Nothing, + CM.addressType = const Nothing, + CM.snocket = diNtcSnocket, + CM.makeBearer = diNtcBearer, + CM.configureSocket = \_ _ -> return (), + CM.timeWaitTimeout = local_TIME_WAIT_TIMEOUT, + CM.outboundIdleTimeout = local_PROTOCOL_IDLE_TIMEOUT, + CM.connectionDataFlow = ntcDataFlow, + CM.prunePolicy = Diffusion.Policies.prunePolicy, + CM.stdGen = cmLocalStdGen, + CM.connectionsLimits = localConnectionLimits, + CM.updateVersionData = \a _ -> a, + CM.connStateIdSupply = diConnStateIdSupply + } + + CM.with + localConnectionManagerArguments + localConnectionHandler + classifyHandleError + (InResponderMode localInbInfoChannel) + $ \localConnectionManager-> do + -- + -- run node-to-client server + -- + traceWith tracer . RunLocalServer + =<< Snocket.getLocalAddr diNtcSnocket localSocket + + Server.with + Server.Arguments { + Server.sockets = localSocket :| [], + Server.snocket = diNtcSnocket, + Server.tracer = dtLocalServerTracer, + Server.trTracer = nullTracer, -- TODO: issue #3320 + Server.debugInboundGovernor = nullTracer, + Server.inboundGovernorTracer = dtLocalInboundGovernorTracer, + Server.inboundIdleTimeout = Nothing, + Server.connectionLimits = localConnectionLimits, + Server.connectionManager = localConnectionManager, + Server.connectionDataFlow = ntcDataFlow, + Server.inboundInfoChannel = localInbInfoChannel + } + (\inboundGovernorThread _ -> Async.wait inboundGovernorThread) + + + -- | mkRemoteThread - create remote connection manager + + mkRemoteThread :: ThreadId m -> m Void + mkRemoteThread mainThreadId = do + labelThisThread "remote connection manager" + let + exitPolicy :: ExitPolicy a + exitPolicy = stdExitPolicy daReturnPolicy + + ipv4Address + <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) + daIPv4Address + case ipv4Address of + Just addr | Just IPv4Address <- diNtnAddressType addr + -> pure () + | otherwise + -> throwIO (UnexpectedIPv4Address addr) + Nothing -> pure () + + ipv6Address + <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) + daIPv6Address + case ipv6Address of + Just addr | Just IPv6Address <- diNtnAddressType addr + -> pure () + | otherwise + -> throwIO (UnexpectedIPv6Address addr) + Nothing -> pure () + + lookupReqs <- case (ipv4Address, ipv6Address) of + (Just _ , Nothing) -> return LookupReqAOnly + (Nothing, Just _ ) -> return LookupReqAAAAOnly + (Just _ , Just _ ) -> return LookupReqAAndAAAA + (Nothing, Nothing) -> throwIO NoSocket + -- RNGs used for picking random peers from the ledger and for + -- demoting/promoting peers. + policyRngVar <- newTVarIO policyRng --- | Tracers which depend on p2p mode. + localRootsVar <- newTVarIO mempty + + peerSelectionTargetsVar <- newTVarIO daPeerSelectionTargets + + countersVar <- newTVarIO (emptyPeerSelectionCounters daEmptyExtraCounters) + + -- Design notes: + -- - We split the following code into two parts: + -- - Part (a): plumb data flow (in particular arguments and tracersr) + -- and define common functions as a sequence of 'let's in which we + -- define needed 'withXXX' functions (and similar) which + -- - are used in Part (b), + -- - handle the plumbing of tracers, and + -- - capture commonalities between the two cases. + -- + -- - Part (b): capturing the major control-flow of runM: + -- in particular, two different case alternatives in which is captured + -- the monadic flow of the program stripped down to its essence: + --- ``` + -- + -- case diffusionMode of + -- InitiatorOnlyDiffusionMode -> ... + -- InitiatorAndResponderDiffusionMode -> ... + -- ``` + + -- + -- Part (a): plumb data flow and define common functions + -- + + let connectionManagerArguments' + :: forall handle handleError. + PrunePolicy ntnAddr + -> StdGen + -> CM.Arguments + (ConnectionHandlerTrace ntnVersion ntnVersionData) + ntnFd ntnAddr handle handleError ntnVersion ntnVersionData m + connectionManagerArguments' prunePolicy stdGen = + CM.Arguments { + CM.tracer = dtConnectionManagerTracer, + CM.trTracer = + fmap CM.abstractState + `contramap` dtConnectionManagerTransitionTracer, + CM.muxTracer = dtMuxTracer, + CM.ipv4Address, + CM.ipv6Address, + CM.addressType = diNtnAddressType, + CM.snocket = diNtnSnocket, + CM.makeBearer = diNtnBearer, + CM.configureSocket = diNtnConfigureSocket, + CM.connectionDataFlow = diNtnDataFlow, + CM.prunePolicy = prunePolicy, + CM.stdGen, + CM.connectionsLimits = daAcceptedConnectionsLimit, + CM.timeWaitTimeout = daTimeWaitTimeout, + CM.outboundIdleTimeout = daProtocolIdleTimeout, + CM.updateVersionData = diUpdateVersionData, + CM.connStateIdSupply = diConnStateIdSupply + } + + let peerSelectionPolicy = + simplePeerSelectionPolicy + policyRngVar daPeerMetrics (epErrorDelay exitPolicy) + + let makeConnectionHandler' + :: forall muxMode socket initiatorCtx responderCtx b c. + SingMuxMode muxMode + -> Versions ntnVersion ntnVersionData + (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) + -> MuxConnectionHandler + muxMode socket initiatorCtx responderCtx ntnAddr + ntnVersion ntnVersionData ByteString m b c + makeConnectionHandler' muxMode versions = + makeConnectionHandler + dtMuxTracer + muxMode + daMuxForkPolicy + diNtnHandshakeArguments + versions + (mainThreadId, rethrowPolicy <> daRethrowPolicy) + + -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of + -- withConnectionManager: + + withConnectionManagerInitiatorOnlyMode = + CM.with + (connectionManagerArguments' simplePrunePolicy cmStdGen1) + -- Server is not running, it will not be able to + -- advise which connections to prune. It's also not + -- expected that the governor targets will be larger + -- than limits imposed by 'cmConnectionsLimits'. + (makeConnectionHandler' + SingInitiatorMode + daApplicationInitiatorMode) + classifyHandleError + NotInResponderMode + + withConnectionManagerInitiatorAndResponderMode + inbndInfoChannel = + CM.with + (connectionManagerArguments' Diffusion.Policies.prunePolicy cmStdGen2) + (makeConnectionHandler' + SingInitiatorResponderMode + daApplicationInitiatorResponderMode) + classifyHandleError + (InResponderMode inbndInfoChannel) + + -- + -- peer state actions + -- + -- Peer state actions run a job pool in the background which + -- tracks threads forked by 'PeerStateActions' + -- + + let -- | parameterized version of 'withPeerStateActions' + withPeerStateActions' + :: forall (muxMode :: Mx.Mode) responderCtx socket b c. + HasInitiator muxMode ~ True + => MuxConnectionManager + muxMode socket (ExpandedInitiatorContext ntnAddr m) + responderCtx ntnAddr ntnVersionData ntnVersion + ByteString m a b + -> (Governor.PeerStateActions + ntnAddr + (PeerConnectionHandle muxMode responderCtx ntnAddr + ntnVersionData ByteString m a b) + m + -> m c) + -> m c + withPeerStateActions' connectionManager = + withPeerStateActions + PeerStateActionsArguments { + spsTracer = dtPeerSelectionActionsTracer, + spsDeactivateTimeout = Diffusion.Policies.deactivateTimeout, + spsCloseConnectionTimeout = + Diffusion.Policies.closeConnectionTimeout, + spsConnectionManager = connectionManager, + spsExitPolicy = exitPolicy, + spsRethrowPolicy = rethrowPolicy, + spsMainThreadId = mainThreadId + } + + dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore + let dnsActions = + PeerActionsDNS { + paToPeerAddr = diNtnToPeerAddr + , paDnsActions = diDnsActions lookupReqs + } + -- + -- Run peer selection (p2p governor) + -- + let + withPeerSelectionActions' + :: m (Map ntnAddr PeerSharing) + -> PeerStateActions + ntnAddr + (PeerConnectionHandle + muxMode responderCtx ntnAddr ntnVersionData bytes m a b) + m + -> ((Async m Void, Async m Void) + -> PeerSelectionActions + extraState + extraFlags + extraPeers + extraAPI + extraCounters + ntnAddr + (PeerConnectionHandle + muxMode responderCtx ntnAddr ntnVersionData bytes m a b) + m + -> m c) + -> m c + withPeerSelectionActions' readInboundPeers peerStateActions = + withPeerSelectionActions dtTraceLocalRootPeersTracer + localRootsVar + dnsActions + (\getLedgerPeers -> PeerSelectionActions { + peerSelectionTargets = daPeerSelectionTargets, + readPeerSelectionTargets = readTVar peerSelectionTargetsVar, + getLedgerStateCtx = daLedgerPeersCtx, + readLocalRootPeersFromFile = daReadLocalRootPeers, + readLocalRootPeers = readTVar localRootsVar, + peerSharing = daOwnPeerSharing, + peerConnToPeerSharing = pchPeerSharing diNtnPeerSharing, + requestPeerShare = + requestPeerSharingResult (readTVar (getPeerSharingRegistry daPeerSharingRegistry)), + requestPublicRootPeers = + case daRequestPublicRootPeers of + Nothing -> + Ouroboros.requestPublicRootPeers + dtTracePublicRootPeersTracer + daReadPublicRootPeers + dnsActions + dnsSemaphore + daToExtraPeers + getLedgerPeers + Just requestPublicRootPeers' -> + requestPublicRootPeers' dnsActions dnsSemaphore daToExtraPeers getLedgerPeers, + readInboundPeers = + case daOwnPeerSharing of + PeerSharingDisabled -> pure Map.empty + PeerSharingEnabled -> readInboundPeers, + readLedgerPeerSnapshot = daReadLedgerPeerSnapshot, + extraPeersAPI = daExtraPeersAPI, + extraStateToExtraCounters = daPeerSelectionStateToExtraCounters, + peerStateActions + }) + WithLedgerPeersArgs { + wlpRng = ledgerPeersRng, + wlpConsensusInterface = daLedgerPeersCtx, + wlpTracer = dtTraceLedgerPeersTracer, + wlpGetUseLedgerPeers = daReadUseLedgerPeers, + wlpGetLedgerPeerSnapshot = daReadLedgerPeerSnapshot, + wlpSemaphore = dnsSemaphore + } + + peerSelectionGovernor' + :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) + -> StrictTVar m (PeerSelectionState extraState extraFlags extraPeers ntnAddr + (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData ByteString m a b)) + -> PeerSelectionActions + extraState extraFlags extraPeers + extraAPI extraCounters ntnAddr + (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData ByteString m a b) + m + -> m Void + peerSelectionGovernor' peerSelectionTracer dbgVar peerSelectionActions = + Governor.peerSelectionGovernor + dtTracePeerSelectionTracer + peerSelectionTracer + dtTracePeerSelectionCounters + daPeerSelectionGovernorArgs + fuzzRng + daEmptyExtraState + mempty + peerSelectionActions + peerSelectionPolicy + PeerSelectionInterfaces { + countersVar, + publicStateVar = daPublicPeerSelectionVar, + debugStateVar = dbgVar, + readUseLedgerPeers = daReadUseLedgerPeers + } + + + -- + -- The peer churn governor: + -- + let peerChurnGovernor' = + daPeerChurnGovernor + PeerChurnArgs { + pcaPeerSelectionTracer = dtTracePeerSelectionTracer + , pcaChurnTracer = dtTraceChurnCounters + , pcaDeadlineInterval = daDeadlineChurnInterval + , pcaBulkInterval = daBulkChurnInterval + , pcaPeerRequestTimeout = policyPeerShareOverallTimeout peerSelectionPolicy + , pcaMetrics = daPeerMetrics + , pcaRng = churnRng + , pcaPeerSelectionVar = peerSelectionTargetsVar + , pcaReadCounters = readTVar countersVar + , getLedgerStateCtx = daLedgerPeersCtx + , getLocalRootHotTarget = + LocalRootPeers.hotTarget + . LocalRootPeers.fromGroups + <$> readTVar localRootsVar + , getOriginalPeerTargets = daPeerSelectionTargets + , getExtraArgs = daExtraChurnArgs + } + + -- + -- Two functions only used in InitiatorAndResponder mode + -- + let + -- create sockets + withSockets' f = + withSockets tracer diNtnSnocket + (\sock addr -> diNtnConfigureSocket sock (Just addr)) + (\sock addr -> diNtnConfigureSystemdSocket sock addr) + ( catMaybes + [ daIPv4Address + , daIPv6Address + ] + ) + f + + -- run node-to-node server + withServer sockets connectionManager inboundInfoChannel = + Server.with + Server.Arguments { + Server.sockets = sockets, + Server.snocket = diNtnSnocket, + Server.tracer = dtServerTracer, + Server.trTracer = dtInboundGovernorTransitionTracer, + Server.debugInboundGovernor = nullTracer, + Server.inboundGovernorTracer = dtInboundGovernorTracer, + Server.connectionLimits = daAcceptedConnectionsLimit, + Server.connectionManager = connectionManager, + Server.connectionDataFlow = diNtnDataFlow, + Server.inboundIdleTimeout = Just daProtocolIdleTimeout, + Server.inboundInfoChannel = inboundInfoChannel + } + + -- + -- Part (b): capturing the major control-flow of runM: + -- + case diffusionMode of + + -- InitiatorOnly mode, run peer selection only: + InitiatorOnlyDiffusionMode -> + withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do + debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng daEmptyExtraState mempty + diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics + withPeerStateActions' connectionManager $ \peerStateActions-> + withPeerSelectionActions' + (return Map.empty) + peerStateActions $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> + Async.withAsync + (peerSelectionGovernor' + dtDebugPeerSelectionInitiatorTracer + debugStateVar + peerSelectionActions) $ \governorThread -> + Async.withAsync + peerChurnGovernor' $ \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny + [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread] + + -- InitiatorAndResponder mode, run peer selection and the server: + InitiatorAndResponderDiffusionMode -> do + inboundInfoChannel <- newInformationChannel + withConnectionManagerInitiatorAndResponderMode + inboundInfoChannel $ \connectionManager -> + -- + -- node-to-node sockets + -- + withSockets' $ \sockets addresses -> do + -- + -- node-to-node server + -- + withServer sockets connectionManager inboundInfoChannel $ + \inboundGovernorThread readInboundState -> do + debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng daEmptyExtraState mempty + diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics + withPeerStateActions' connectionManager $ + \peerStateActions -> + withPeerSelectionActions' + (mkInboundPeersMap <$> readInboundState) + peerStateActions $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> + Async.withAsync + (do + labelThisThread "Peer selection governor" + peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ + \governorThread -> do + -- begin, unique to InitiatorAndResponder mode: + traceWith tracer (RunServer addresses) + -- end, unique to ... + Async.withAsync (do + labelThisThread "Peer churn governor" + peerChurnGovernor') $ + \churnGovernorThread -> + -- wait for any thread to fail: + snd <$> Async.waitAny [ ledgerPeersThread + , localRootPeersProvider + , governorThread + , churnGovernorThread + , inboundGovernorThread + ] + +-- | Main entry point for data diffusion service. It allows to: +-- +-- * connect to upstream peers; +-- * accept connection from downstream peers, if run in +-- 'InitiatorAndResponderDiffusionMode'. +-- * runs a local service which allows to use node-to-client protocol to obtain +-- information from the running system. This is used by 'cardano-cli' or +-- a wallet and a like local services. -- -data ExtraTracers (p2p :: P2P) extraState extraDebugState extraFlags extraPeers extraCounters m where - P2PTracers - :: P2P.TracersExtra - RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - IOException extraState extraDebugState extraFlags extraPeers - extraCounters m - -> ExtraTracers 'P2P extraState extraDebugState extraFlags extraPeers extraCounters m +run :: ( Monoid extraPeers + , Eq extraFlags + , Eq extraCounters + , Exception exception + ) + => ( forall (mode :: Mx.Mode) x y. + NodeToNodeConnectionManager mode Socket + RemoteAddress NodeToNodeVersionData + NodeToNodeVersion IO x y + -> StrictTVar IO + (PeerSelectionState extraState extraFlags extraPeers + RemoteAddress + (NodeToNodePeerConnectionHandle + mode RemoteAddress + NodeToNodeVersionData IO x y)) + -> PeerMetrics IO RemoteAddress + -> IO ()) + -> Tracers + RemoteAddress + NodeToNodeVersion + NodeToNodeVersionData + LocalAddress + NodeToClientVersion + NodeToClientVersionData + IOException + extraState + extraDebugState + extraFlags + extraPeers + extraCounters + IO + -> Arguments + extraState + extraDebugState + extraFlags + extraPeers + extraAPI + extraChurnArgs + extraCounters + exception + Resolver + IOException + IO + Socket + RemoteAddress + LocalSocket + LocalAddress + -> Applications + RemoteAddress + NodeToNodeVersion + NodeToNodeVersionData + LocalAddress + NodeToClientVersion + NodeToClientVersionData + extraAPI + IO + a + -> IO Void +run sigUSR1Signal tracers args apps = do + let tracer = dtDiffusionTracer tracers + diNtnHandshakeArguments = + HandshakeArguments { + haHandshakeTracer = dtHandshakeTracer tracers, + haHandshakeCodec = NodeToNode.nodeToNodeHandshakeCodec, + haVersionDataCodec = + cborTermVersionDataCodec + NodeToNode.nodeToNodeCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = timeLimitsHandshake + } + diNtcHandshakeArguments = + HandshakeArguments { + haHandshakeTracer = dtLocalHandshakeTracer tracers, + haHandshakeCodec = NodeToClient.nodeToClientHandshakeCodec, + haVersionDataCodec = + cborTermVersionDataCodec + NodeToClient.nodeToClientCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } - NonP2PTracers - :: NonP2P.TracersExtra - -> ExtraTracers 'NonP2P extraState extraDebugState extraFlags extraPeers extraCounters m + diRng <- newStdGen + diConnStateIdSupply <- atomically $ CM.newConnStateIdSupply Proxy + + -- We run two services: for /node-to-node/ and /node-to-client/. The + -- naming convention is that we use /local/ prefix for /node-to-client/ + -- related terms, as this is a local only service running over a unix + -- socket / windows named pipe. + handleJust (\e -> case fromException e :: Maybe ExitCode of + Nothing -> Just e + Just {} -> Nothing) + (\e -> traceWith tracer (DiffusionErrored e) + >> throwIO (DiffusionError e)) + $ withIOManager $ \iocp -> do + runM + Interfaces { + diNtnSnocket = Snocket.socketSnocket iocp, + diNtnBearer = makeSocketBearer, + diNtnConfigureSocket = configureSocket, + diNtnConfigureSystemdSocket = + configureSystemdSocket + (SystemdSocketConfiguration `contramap` tracer), + diNtnAddressType = socketAddressType, + diNtnDataFlow = ntnDataFlow, + diNtnPeerSharing = peerSharing, + diNtnToPeerAddr = curry IP.toSockAddr, + diNtcSnocket = Snocket.localSnocket iocp, + diNtcBearer = makeLocalBearer, + diNtcGetFileDescriptor = localSocketFileDescriptor, + diDnsActions = ioDNSActions, + diInstallSigUSR1Handler = sigUSR1Signal, + diNtnHandshakeArguments, + diNtcHandshakeArguments, + diRng, + diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode }, + diConnStateIdSupply + } + tracers args apps --- | Diffusion arguments which depend on p2p mode. -- -data ArgumentsExtra - (p2p :: P2P) extraArgs extraState extraDebugState extraAPI - extraFlags extraPeers extraChurnArgs extraCounters exception ntnAddr ntcAddr resolver resolverError m where - P2PArguments - :: P2P.ArgumentsExtra extraState extraDebugState extraAPI - extraFlags extraPeers extraChurnArgs - extraCounters exception ntnAddr ntcAddr resolver resolverError m - -> ArgumentsExtra 'P2P extraArgs extraState extraDebugState extraAPI - extraFlags extraPeers extraChurnArgs - extraCounters exception ntnAddr ntcAddr resolver resolverError m - - NonP2PArguments - :: NonP2P.ArgumentsExtra - -> ArgumentsExtra 'NonP2P extraArgs extraState extraDebugState extraAPI - extraFlags extraPeers extraChurnArgs - extraCounters exception ntnAddr ntcAddr resolver resolverError m - - --- | Application data which depend on p2p mode. +-- Data flow -- -data ApplicationsExtra (p2p :: P2P) ntnAddr m a where - P2PApplicationsExtra - :: P2P.ApplicationsExtra ntnAddr m a - -> ApplicationsExtra 'P2P ntnAddr m a - NonP2PApplicationsExtra - :: NonP2P.ApplicationsExtra - -> ApplicationsExtra 'NonP2P ntnAddr m a +-- | Node-To-Node protocol connections which negotiated +-- `InitiatorAndResponderDiffusionMode` are `Duplex`. +-- +ntnDataFlow :: NodeToNodeVersionData -> DataFlow +ntnDataFlow NodeToNodeVersionData { diffusionMode } = + case diffusionMode of + InitiatorAndResponderDiffusionMode -> Duplex + InitiatorOnlyDiffusionMode -> Unidirectional --- | Run data diffusion in either 'P2P' or 'NonP2P' mode. +-- | All Node-To-Client protocol connections are considered 'Unidirectional'. -- -run :: forall (p2p :: P2P) extraArgs extraState extraDebugState extraFlags - extraPeers extraAPI extraChurnArgs extraCounters exception a. - ( Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) - => (forall mode x y. - P2P.NodeToNodeConnectionManager mode Socket - RemoteAddress NodeToNodeVersionData - NodeToNodeVersion IO x y - -> StrictTVar IO - (PeerSelectionState extraState extraFlags extraPeers - RemoteAddress - (P2P.NodeToNodePeerConnectionHandle - mode RemoteAddress - NodeToNodeVersionData IO x y)) - -> PeerMetrics IO RemoteAddress - -> IO ()) - -> Tracers - RemoteAddress NodeToNodeVersion - LocalAddress NodeToClientVersion - IO - -> ExtraTracers p2p extraState extraDebugState extraFlags extraPeers extraCounters IO - -> Arguments - IO - Socket RemoteAddress - LocalSocket LocalAddress - -> ArgumentsExtra p2p extraArgs extraState extraDebugState - extraFlags extraPeers - extraAPI extraChurnArgs extraCounters exception - RemoteAddress LocalAddress Resolver IOException IO - -> Applications RemoteAddress NodeToNodeVersion NodeToNodeVersionData - LocalAddress NodeToClientVersion NodeToClientVersionData - extraAPI IO a - -> ApplicationsExtra p2p RemoteAddress IO a - -> IO () -run sigUSR1Signal - tracers (P2PTracers tracersExtra) - args (P2PArguments argsExtra) - apps - (P2PApplicationsExtra appsExtra) = - void $ - P2P.run - sigUSR1Signal tracers tracersExtra - args argsExtra apps appsExtra -run _ - tracers (NonP2PTracers tracersExtra) - args (NonP2PArguments argsExtra) - apps - (NonP2PApplicationsExtra appsExtra) = do - NonP2P.run tracers tracersExtra - args argsExtra - apps appsExtra +ntcDataFlow :: ntcVersionData -> DataFlow +ntcDataFlow _ = Unidirectional diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs deleted file mode 100644 index d3f94bbad56..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Common.hs +++ /dev/null @@ -1,196 +0,0 @@ --- Common things between P2P and NonP2P Diffusion modules -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Ouroboros.Network.Diffusion.Common - ( DiffusionTracer (..) - , Failure (..) - , Tracers (..) - , nullTracers - , Arguments (..) - , Applications (..) - , AcceptedConnectionsLimit (..) - ) where - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow -import Control.Tracer (Tracer, nullTracer) -import Data.ByteString.Lazy (ByteString) -import Data.List.NonEmpty (NonEmpty) -import Data.Typeable (Typeable) -import Data.Void (Void) - -import Network.Mux qualified as Mx - -import Ouroboros.Network.ConnectionId (ConnectionId) -import Ouroboros.Network.Mux hiding (MiniProtocol (..)) -import Ouroboros.Network.NodeToClient qualified as NodeToClient -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, DiffusionMode) -import Ouroboros.Network.NodeToNode qualified as NodeToNode -import Ouroboros.Network.PeerSelection.Governor.Types (PublicPeerSelectionState) -import Ouroboros.Network.PeerSelection.LedgerPeers - (LedgerPeersConsensusInterface) -import Ouroboros.Network.Protocol.Handshake -import Ouroboros.Network.Snocket (FileDescriptor) -import Ouroboros.Network.Socket (SystemdSocketTracer) - --- | The 'DiffusionTracer' logs --- --- * diffusion initialisation messages --- * terminal errors thrown by diffusion --- -data DiffusionTracer ntnAddr ntcAddr - = RunServer (NonEmpty ntnAddr) - | RunLocalServer ntcAddr - | UsingSystemdSocket ntcAddr - -- Rename as 'CreateLocalSocket' - | CreateSystemdSocketForSnocketPath ntcAddr - | CreatedLocalSocket ntcAddr - | ConfiguringLocalSocket ntcAddr FileDescriptor - | ListeningLocalSocket ntcAddr FileDescriptor - | LocalSocketUp ntcAddr FileDescriptor - -- Rename as 'CreateServerSocket' - | CreatingServerSocket ntnAddr - | ConfiguringServerSocket ntnAddr - | ListeningServerSocket ntnAddr - | ServerSocketUp ntnAddr - -- Rename as 'UnsupportedLocalSocketType' - | UnsupportedLocalSystemdSocket ntnAddr - -- Remove (this is impossible case), there's no systemd on Windows - | UnsupportedReadySocketCase - | DiffusionErrored SomeException - | SystemdSocketConfiguration SystemdSocketTracer - deriving Show - --- TODO: add a tracer for these misconfiguration -data Failure where - UnsupportedReadySocket :: Failure - UnexpectedIPv4Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure - UnexpectedIPv6Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure - NoSocket :: Failure - DiffusionError :: SomeException -> Failure - -deriving instance Show Failure -instance Exception Failure - --- | Common DiffusionTracers interface between P2P and NonP2P --- -data Tracers ntnAddr ntnVersion ntcAddr ntcVersion m = Tracers { - -- | Mux tracer - dtMuxTracer - :: Tracer m (Mx.WithBearer (ConnectionId ntnAddr) Mx.Trace) - - -- | Handshake protocol tracer - , dtHandshakeTracer - :: Tracer m (NodeToNode.HandshakeTr ntnAddr ntnVersion) - - -- - -- NodeToClient tracers - -- - - -- | Mux tracer for local clients - , dtLocalMuxTracer - :: Tracer m (Mx.WithBearer (ConnectionId ntcAddr) Mx.Trace) - - -- | Handshake protocol tracer for local clients - , dtLocalHandshakeTracer - :: Tracer m (NodeToClient.HandshakeTr ntcAddr ntcVersion) - - -- | Diffusion initialisation tracer - , dtDiffusionTracer - :: Tracer m (DiffusionTracer ntnAddr ntcAddr) - } - - -nullTracers :: Applicative m - => Tracers ntnAddr ntnVersion - ntcAddr ntcVersion - m -nullTracers = Tracers { - dtMuxTracer = nullTracer - , dtHandshakeTracer = nullTracer - , dtLocalMuxTracer = nullTracer - , dtLocalHandshakeTracer = nullTracer - , dtDiffusionTracer = nullTracer - } - --- | Common DiffusionArguments interface between P2P and NonP2P --- -data Arguments m ntnFd ntnAddr ntcFd ntcAddr = Arguments { - -- | an @IPv4@ socket ready to accept connections or an @IPv4@ addresses - -- - daIPv4Address :: Maybe (Either ntnFd ntnAddr) - - -- | an @IPv6@ socket ready to accept connections or an @IPv6@ addresses - -- - , daIPv6Address :: Maybe (Either ntnFd ntnAddr) - - -- | an @AF_UNIX@ socket ready to accept connections or an @AF_UNIX@ - -- socket path - , daLocalAddress :: Maybe (Either ntcFd ntcAddr) - - -- | parameters for limiting number of accepted connections - -- - , daAcceptedConnectionsLimit :: AcceptedConnectionsLimit - - -- | run in initiator only mode - -- - , daMode :: DiffusionMode - - -- | public peer selection state - -- - -- It is created outside of diffusion, since it is needed to create some - -- apps (e.g. peer sharing). - -- - , daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState ntnAddr) - } - - --- | Versioned mini-protocol bundles run on a negotiated connection. --- -data Applications ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - extraAPI m a = - Applications { - -- | NodeToNode initiator applications for initiator only mode. - -- - -- TODO: we should accept one or the other, but not both: - -- 'daApplicationInitiatorMode', 'daApplicationInitiatorResponderMode'. - -- - -- Even in non-p2p mode we use p2p apps. - daApplicationInitiatorMode - :: Versions ntnVersion - ntnVersionData - (OuroborosBundleWithExpandedCtx - Mx.InitiatorMode ntnAddr - ByteString m a Void) - - -- | NodeToNode initiator & responder applications for bidirectional mode. - -- - , daApplicationInitiatorResponderMode - -- Peer Sharing result computation callback - :: Versions ntnVersion - ntnVersionData - (OuroborosBundleWithExpandedCtx - Mx.InitiatorResponderMode ntnAddr - ByteString m a ()) - - -- | NodeToClient responder application (server role) - -- - -- Because p2p mode does not infect local connections we we use non-p2p - -- apps. - , daLocalResponderApplication - :: Versions ntcVersion - ntcVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode ntcAddr - ByteString m Void ()) - - -- | Interface used to get peers from the current ledger. - -- - -- TODO: it should be in 'InterfaceExtra' - , daLedgerPeersCtx :: LedgerPeersConsensusInterface extraAPI m - } diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs deleted file mode 100644 index f7c857c2f81..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ /dev/null @@ -1,1485 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - --- | This module is expected to be imported qualified (it will clash --- with the "Ouroboros.Network.Diffusion.NonP2P"). --- -module Ouroboros.Network.Diffusion.P2P - ( TracersExtra (..) - , nullTracersExtra - , ArgumentsExtra (..) - , ApplicationsExtra (..) - , run - , Interfaces (..) - , runM - -- * NodeToClient type aliases - , NodeToClientHandle - , NodeToClientHandleError - , NodeToClientConnectionHandler - , NodeToClientConnectionManagerArguments - -- * NodeToNode type aliases - , NodeToNodeHandle - , NodeToNodeConnectionManager - , NodeToNodePeerConnectionHandle - , NodeToNodePeerSelectionActions - -- * Re-exports - , AbstractTransitionTrace - , IG.RemoteTransitionTrace - ) where - - -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadMVar (MonadMVar) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Exception (IOException) -import Control.Monad.Class.MonadAsync (Async, MonadAsync) -import Control.Monad.Class.MonadAsync qualified as Async -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -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 (IP) -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.Set (Set) -import Data.Typeable (Proxy (..), Typeable) -import Data.Void (Void) -import System.Exit (ExitCode) -import System.Random (StdGen, newStdGen, split) - -import Network.Socket (Socket) -import Network.Socket qualified as Socket -import Network.Mux qualified as Mx - -import Ouroboros.Network.Context (ResponderContext) -import Ouroboros.Network.Snocket (LocalAddress, LocalSocket (..), Snocket, - localSocketFileDescriptor, makeLocalBearer, makeSocketBearer) -import Ouroboros.Network.Snocket (FileDescriptor) -import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Context (ExpandedInitiatorContext) -import Ouroboros.Network.Protocol.Handshake -import Ouroboros.Network.Protocol.Handshake.Codec -import Ouroboros.Network.Protocol.Handshake.Version -import Ouroboros.Network.Socket (configureSocket, configureSystemdSocket) -import Ouroboros.Network.ConnectionId -import Ouroboros.Network.ConnectionHandler -import Ouroboros.Network.ConnectionManager.Core qualified as CM -import Ouroboros.Network.ConnectionManager.InformationChannel (newInformationChannel) -import Ouroboros.Network.ConnectionManager.State (ConnStateId, - ConnStateIdSupply, newConnStateIdSupply) -import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Diffusion.Common hiding (nullTracers) -import Ouroboros.Network.Diffusion.Configuration -import Ouroboros.Network.Diffusion.Policies (simplePeerSelectionPolicy) -import Ouroboros.Network.Diffusion.Policies qualified as Diffusion.Policies -import Ouroboros.Network.Diffusion.Utils -import Ouroboros.Network.ExitPolicy -import Ouroboros.Network.InboundGovernor qualified as IG -import Ouroboros.Network.IOManager -import Ouroboros.Network.Mux hiding (MiniProtocol (..)) -import Ouroboros.Network.MuxMode -import Ouroboros.Network.NodeToClient (NodeToClientVersion (..), - NodeToClientVersionData) -import Ouroboros.Network.NodeToClient qualified as NodeToClient -import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..), - NodeToNodeVersionData (..), RemoteAddress) -import Ouroboros.Network.NodeToNode qualified as NodeToNode -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters, PeerChurnArgs (..)) -import Ouroboros.Network.PeerSelection.Governor qualified as Governor -import Ouroboros.Network.PeerSelection.Governor.Types hiding (peerSharing) -import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeersKind, - LedgerPeerSnapshot (..), NumberOfPeers, UseLedgerPeers (..), - TraceLedgerPeers, WithLedgerPeersArgs (..)) -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) -import Ouroboros.Network.PeerSelection.PeerMetric -import Ouroboros.Network.PeerSelection.PeerSelectionActions -import Ouroboros.Network.PeerSelection.PeerSelectionActions qualified as Ouroboros -import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, - PeerSelectionActionsTrace, PeerStateActionsArguments (..), - pchPeerSharing, withPeerStateActions) -import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) -import Ouroboros.Network.PeerSelection.RootPeersDNS -import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers - (TraceLocalRootPeers) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers - (TracePublicRootPeers) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions - (DNSActions, DNSLookupType (..), ioDNSActions) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore - (DNSSemaphore, newLedgerAndPublicRootDNSSemaphore) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers -import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI) -import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..)) -import Ouroboros.Network.RethrowPolicy -import Ouroboros.Network.Server2 qualified as Server -import Network.DNS (Resolver) - - --- | P2P DiffusionTracers Extras --- -data TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError extraState extraDebugState - extraFlags extraPeers extraCounters m = - TracersExtra { - dtTraceLocalRootPeersTracer - :: Tracer m (TraceLocalRootPeers extraFlags ntnAddr resolverError) - - , dtTracePublicRootPeersTracer - :: Tracer m TracePublicRootPeers - - -- | Ledger Peers tracer - , dtTraceLedgerPeersTracer - :: Tracer m TraceLedgerPeers - - , dtTracePeerSelectionTracer - :: Tracer m (TracePeerSelection extraDebugState extraFlags extraPeers ntnAddr) - - , dtDebugPeerSelectionInitiatorTracer - :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) - - -- TODO: can be unified with the previous one - , dtDebugPeerSelectionInitiatorResponderTracer - :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) - - , dtTracePeerSelectionCounters - :: Tracer m (PeerSelectionCounters extraCounters) - - , dtTraceChurnCounters - :: Tracer m ChurnCounters - - , dtPeerSelectionActionsTracer - :: Tracer m (PeerSelectionActionsTrace ntnAddr ntnVersion) - - , dtConnectionManagerTracer - :: Tracer m (CM.Trace - ntnAddr - (ConnectionHandlerTrace - ntnVersion - ntnVersionData)) - - , dtConnectionManagerTransitionTracer - :: Tracer m (AbstractTransitionTrace ConnStateId) - - , dtServerTracer - :: Tracer m (Server.Trace ntnAddr) - - , dtInboundGovernorTracer - :: Tracer m (IG.Trace ntnAddr) - - , dtInboundGovernorTransitionTracer - :: Tracer m (IG.RemoteTransitionTrace ntnAddr) - - -- - -- NodeToClient tracers - -- - - -- | Connection manager tracer for local clients - , dtLocalConnectionManagerTracer - :: Tracer m (CM.Trace - ntcAddr - (ConnectionHandlerTrace - ntcVersion - ntcVersionData)) - - -- | Server tracer for local clients - , dtLocalServerTracer - :: Tracer m (Server.Trace ntcAddr) - - -- | Inbound protocol governor tracer for local clients - , dtLocalInboundGovernorTracer - :: Tracer m (IG.Trace ntcAddr) - } - -nullTracersExtra - :: Applicative m - => TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError extraState extraDebugState - extraFlags extraPeers extraCounters m -nullTracersExtra = - TracersExtra { - dtTraceLocalRootPeersTracer = nullTracer - , dtTracePublicRootPeersTracer = nullTracer - , dtTraceLedgerPeersTracer = nullTracer - , dtTracePeerSelectionTracer = nullTracer - , dtTraceChurnCounters = nullTracer - , dtDebugPeerSelectionInitiatorTracer = nullTracer - , dtDebugPeerSelectionInitiatorResponderTracer = nullTracer - , dtTracePeerSelectionCounters = nullTracer - , dtPeerSelectionActionsTracer = nullTracer - , dtConnectionManagerTracer = nullTracer - , dtConnectionManagerTransitionTracer = nullTracer - , dtServerTracer = nullTracer - , dtInboundGovernorTracer = nullTracer - , dtInboundGovernorTransitionTracer = nullTracer - , dtLocalConnectionManagerTracer = nullTracer - , dtLocalServerTracer = nullTracer - , dtLocalInboundGovernorTracer = nullTracer - } - - --- | P2P Arguments Extras --- -data ArgumentsExtra extraState extraDebugState extraFlags extraPeers - extraAPI extraChurnArgs extraCounters exception - ntnAddr ntcAddr resolver resolverError m = ArgumentsExtra { - -- | selection targets for the peer governor - -- - daPeerSelectionTargets :: PeerSelectionTargets - , daReadLocalRootPeers :: STM m (LocalRootPeers.Config extraFlags RelayAccessPoint) - , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) - - -- | Depending on configuration, node may provide us with - -- a snapshot of big ledger peers taken at some slot on the chain. - -- These peers may be selected by ledgerPeersThread when requested - -- by the peer selection governor when the node is syncing up. - -- This is especially useful for Genesis consensus mode. - , daReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) - - -- | Peer's own PeerSharing value. - -- - -- This value comes from the node's configuration file and is static. - , daOwnPeerSharing :: PeerSharing - , daReadUseLedgerPeers :: STM m UseLedgerPeers - - -- | Timeout which starts once all responder protocols are idle. If the - -- responders stay idle for duration of the timeout, the connection will - -- be demoted, if it wasn't used by the p2p-governor it will be closed. - -- - -- Applies to 'Unidirectional' as well as 'Duplex' /node-to-node/ - -- connections. - -- - -- See 'serverProtocolIdleTimeout'. - -- - , daProtocolIdleTimeout :: DiffTime - - -- | Time for which /node-to-node/ connections are kept in - -- 'TerminatingState', it should correspond to the OS configured @TCP@ - -- @TIME_WAIT@ timeout. - -- - -- This timeout will apply to after a connection has been closed, its - -- purpose is to be resilient for delayed packets in the same way @TCP@ - -- is using @TIME_WAIT@. - -- - , daTimeWaitTimeout :: DiffTime - - -- | Churn interval between churn events in deadline mode. A small fuzz - -- is added (max 10 minutes) so that not all nodes churn at the same time. - -- - -- By default it is set to 3300 seconds. - -- - , daDeadlineChurnInterval :: DiffTime - - -- | Churn interval between churn events in bulk sync mode. A small fuzz - -- is added (max 1 minute) so that not all nodes churn at the same time. - -- - -- By default it is set to 300 seconds. - -- - , daBulkChurnInterval :: DiffTime - - -- | Extra State empty value - -- - , daEmptyExtraState :: extraState - - -- | Extra Counters empty value - -- - , daEmptyExtraCounters :: extraCounters - - -- | Provide Public Extra Actions for extraPeers to be - -- - , daExtraPeersAPI :: PublicExtraPeersAPI extraPeers ntnAddr - - , daPeerSelectionGovernorArgs - :: forall muxMode responderCtx ntnVersionData bytes a b . - PeerSelectionGovernorArgs extraState extraDebugState extraFlags extraPeers - extraAPI extraCounters - ntnAddr (PeerConnectionHandle - muxMode responderCtx ntnAddr - ntnVersionData bytes m a b) - exception m - - -- | Function that computes extraCounters from PeerSelectionState - -- - , daPeerSelectionStateToExtraCounters - :: forall muxMode responderCtx ntnVersionData bytes a b . - PeerSelectionState extraState extraFlags extraPeers - ntnAddr (PeerConnectionHandle - muxMode responderCtx ntnAddr - ntnVersionData bytes m a b) - -> extraCounters - - -- | Function that constructs a 'extraPeers' set from a map of dns - -- lookup results. - -- - , daToExtraPeers :: Map ntnAddr PeerAdvertise -> extraPeers - - -- | Request Public Root Peers. - -- - -- If no custom public root peers is provided (i.e. Nothing) just the - -- default one from - -- 'Ouroboros.Network.PeerSelection.PeerSelectionActions.getPublicRootPeers' - -- - , daRequestPublicRootPeers - :: Maybe ( PeerActionsDNS ntnAddr resolver resolverError m - -> DNSSemaphore m - -> (Map ntnAddr PeerAdvertise -> extraPeers) - -> ( (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set ntnAddr, DiffTime))) - -> LedgerPeersKind - -> Int - -> m (PublicRootPeers extraPeers ntnAddr, DiffTime))) - - -- | Peer Churn Governor if no custom churn governor is required just - -- use the default one from - -- 'Ouroboros.Network.PeerSelection.Churn.peerChurnGovernor' - -- - , daPeerChurnGovernor - :: PeerChurnArgs - m - extraChurnArgs - extraDebugState - extraFlags - extraPeers - extraAPI - extraCounters - ntnAddr - -> m Void - - -- | Provide extraChurnArgs to be passed to churn governor - -- - , daExtraChurnArgs :: extraChurnArgs - - -- | A fork policy for node-to-node mini-protocol threads spawn by mux. - -- - , daMuxForkPolicy :: ForkPolicy ntnAddr - - -- | A fork policy for node-to-client mini-protocols threads spawn by mux. - -- - , daLocalMuxForkPolicy :: ForkPolicy ntcAddr - } - - -socketAddressType :: Socket.SockAddr -> Maybe AddressType -socketAddressType Socket.SockAddrInet {} = Just IPv4Address -socketAddressType Socket.SockAddrInet6 {} = Just IPv6Address -socketAddressType Socket.SockAddrUnix {} = Nothing - - --- | P2P Applications Extras --- --- TODO: we need initiator only mode for Daedalus, there's no reason why it --- should run a node-to-node server side. --- -data ApplicationsExtra ntnAddr m a = - ApplicationsExtra { - -- | /node-to-node/ rethrow policy - -- - daRethrowPolicy :: RethrowPolicy - - -- | /node-to-node/ return policy - -- - , daReturnPolicy :: ReturnPolicy a - - -- | /node-to-client/ rethrow policy - -- - , daLocalRethrowPolicy :: RethrowPolicy - - -- | 'PeerMetrics' used by peer selection policy (see - -- 'simplePeerSelectionPolicy') - -- - , daPeerMetrics :: PeerMetrics m ntnAddr - - -- | Used for peer sharing protocol - -- - , daPeerSharingRegistry :: PeerSharingRegistry ntnAddr m - } - - --- --- Node-To-Client type aliases --- --- Node-To-Client diffusion is only used in 'ResponderMode'. --- - -type NodeToClientHandle ntcAddr versionData m = - HandleWithMinimalCtx Mx.ResponderMode ntcAddr versionData ByteString m Void () - -type NodeToClientHandleError ntcVersion = - HandleError Mx.ResponderMode ntcVersion - -type NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m = - ConnectionHandler - Mx.ResponderMode - (ConnectionHandlerTrace ntcVersion ntcVersionData) - ntcFd - ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) - (NodeToClientHandleError ntcVersion) - ntcVersion - ntcVersionData - m - -type NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m = - CM.Arguments - (ConnectionHandlerTrace ntcVersion ntcVersionData) - ntcFd - ntcAddr - (NodeToClientHandle ntcAddr ntcVersionData m) - (NodeToClientHandleError ntcVersion) - ntcVersion - ntcVersionData - m - - --- --- Node-To-Node type aliases --- --- Node-To-Node diffusion runs in either 'InitiatorMode' or 'InitiatorResponderMode'. --- - -type NodeToNodeHandle - (mode :: Mx.Mode) - ntnAddr ntnVersionData m a b = - HandleWithExpandedCtx mode ntnAddr ntnVersionData ByteString m a b - -type NodeToNodeConnectionManager - (mode :: Mx.Mode) - ntnFd ntnAddr ntnVersionData ntnVersion m a b = - ConnectionManager - mode - ntnFd - ntnAddr - (NodeToNodeHandle mode ntnAddr ntnVersionData m a b) - (HandleError mode ntnVersion) - m - --- --- Governor type aliases --- - -type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = - PeerConnectionHandle - mode - (ResponderContext ntnAddr) - ntnAddr - ntnVersionData - ByteString - m a b - -type NodeToNodePeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters - (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = - PeerSelectionActions - extraState extraFlags extraPeers extraAPI extraCounters - ntnAddr - (NodeToNodePeerConnectionHandle mode ntnAddr ntnVersionData m a b) - m - - -data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData - ntcFd ntcAddr ntcVersion ntcVersionData - resolver resolverError - extraState extraFlags extraPeers extraAPI - m = - Interfaces { - -- | node-to-node snocket - -- - diNtnSnocket - :: Snocket m ntnFd ntnAddr, - - -- | node-to-node 'Mx.MakeBearer' callback - -- - diNtnBearer - :: Mx.MakeBearer m ntnFd, - - -- | node-to-node socket configuration - -- - diNtnConfigureSocket - :: ntnFd -> Maybe ntnAddr -> m (), - - -- | node-to-node systemd socket configuration - -- - diNtnConfigureSystemdSocket - :: ntnFd -> ntnAddr -> m (), - - -- | node-to-node handshake configuration - -- - diNtnHandshakeArguments - :: HandshakeArguments (ConnectionId ntnAddr) ntnVersion ntnVersionData m, - - -- | node-to-node address type - -- - diNtnAddressType - :: ntnAddr -> Maybe AddressType, - - -- | node-to-node data flow used by connection manager to classify - -- negotiated connections - -- - diNtnDataFlow - :: ntnVersionData -> DataFlow, - - -- | remote side peer sharing information used by peer selection governor - -- to decide which peers are available for performing peer sharing - diNtnPeerSharing - :: ntnVersionData -> PeerSharing, - - -- | node-to-node peer address - -- - diNtnToPeerAddr - :: IP -> Socket.PortNumber -> ntnAddr, - - -- | node-to-client snocket - -- - diNtcSnocket - :: Snocket m ntcFd ntcAddr, - - -- | node-to-client 'Mx.MakeBearer' callback - -- - diNtcBearer - :: Mx.MakeBearer m ntcFd, - - -- | node-to-client handshake configuration - -- - diNtcHandshakeArguments - :: HandshakeArguments (ConnectionId ntcAddr) ntcVersion ntcVersionData m, - - -- | node-to-client file descriptor - -- - diNtcGetFileDescriptor - :: ntcFd -> m FileDescriptor, - - -- | diffusion pseudo random generator. It is split between various - -- components that need randomness, e.g. inbound governor, peer - -- selection, policies, etc. - -- - diRng - :: StdGen, - - -- | callback which is used to register @SIGUSR1@ signal handler. - diInstallSigUSR1Handler - :: forall mode x y. - NodeToNodeConnectionManager mode ntnFd - ntnAddr ntnVersionData - ntnVersion m x y - -> StrictTVar m - (PeerSelectionState extraState extraFlags extraPeers - ntnAddr - (NodeToNodePeerConnectionHandle - mode ntnAddr - ntnVersionData m x y)) - -> PeerMetrics m ntnAddr - -> m (), - - -- | diffusion dns actions - -- - diDnsActions - :: DNSLookupType -> DNSActions resolver resolverError m, - - -- | Update `ntnVersionData` for initiator-only local roots. - diUpdateVersionData - :: ntnVersionData -> DiffusionMode -> ntnVersionData, - - -- | `ConnStateIdSupply` used by the connection-manager for this node. - -- - -- This is exposed for testing, where we use a global - -- `ConnStateIdSupply`. - -- - diConnStateIdSupply - :: ConnStateIdSupply m - } - - -runM - :: forall m ntnFd ntnAddr ntnVersion ntnVersionData - ntcFd ntcAddr ntcVersion ntcVersionData - resolver resolverError exception a - extraState extraDebugState extraPeers - extraAPI extraFlags extraChurnArgs extraCounters . - - ( Alternative (STM m) - , MonadAsync m - , MonadDelay m - , MonadEvaluate m - , MonadFix m - , MonadFork m - , MonadLabelledSTM m - , MonadTraceSTM m - , MonadMask m - , MonadThrow (STM m) - , MonadTime m - , MonadTimer m - , MonadMVar m - , Typeable ntnAddr - , Ord ntnAddr - , Show ntnAddr - , Hashable ntnAddr - , Typeable ntnVersion - , Ord ntnVersion - , Show ntnVersion - , Show ntnVersionData - , Typeable ntcAddr - , Ord ntcAddr - , Show ntcAddr - , Ord ntcVersion - , Exception resolverError - , Monoid extraPeers - , Eq extraFlags - , Eq extraCounters - , Exception exception - ) - => -- | interfaces - Interfaces ntnFd ntnAddr ntnVersion ntnVersionData - ntcFd ntcAddr ntcVersion ntcVersionData - resolver resolverError - extraState extraFlags extraPeers extraAPI m - -> -- | tracers - Tracers ntnAddr ntnVersion - ntcAddr ntcVersion - m - -> -- | p2p tracers - TracersExtra ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - resolverError - extraState extraDebugState extraFlags - extraPeers extraCounters m - -> -- | configuration - Arguments m ntnFd ntnAddr - ntcFd ntcAddr - -> -- | p2p configuration - ArgumentsExtra extraState extraDebugState extraFlags - extraPeers extraAPI extraChurnArgs extraCounters - exception ntnAddr ntcAddr resolver resolverError m - - -> -- | protocol handlers - Applications ntnAddr ntnVersion ntnVersionData - ntcAddr ntcVersion ntcVersionData - extraAPI m a - -> -- | p2p protocol handlers - ApplicationsExtra ntnAddr m a - -> m Void -runM Interfaces - { diNtnSnocket - , diNtnBearer - , diNtnConfigureSocket - , diNtnConfigureSystemdSocket - , diNtnHandshakeArguments - , diNtnAddressType - , diNtnDataFlow - , diNtnPeerSharing - , diNtnToPeerAddr - , diNtcSnocket - , diNtcBearer - , diNtcHandshakeArguments - , diNtcGetFileDescriptor - , diRng - , diInstallSigUSR1Handler - , diDnsActions - , diUpdateVersionData - , diConnStateIdSupply - } - Tracers - { dtMuxTracer - , dtLocalMuxTracer - , dtDiffusionTracer = tracer - } - TracersExtra - { dtTracePeerSelectionTracer - , dtTraceChurnCounters - , dtDebugPeerSelectionInitiatorTracer - , dtDebugPeerSelectionInitiatorResponderTracer - , dtTracePeerSelectionCounters - , dtPeerSelectionActionsTracer - , dtTraceLocalRootPeersTracer - , dtTracePublicRootPeersTracer - , dtTraceLedgerPeersTracer - , dtConnectionManagerTracer - , dtConnectionManagerTransitionTracer - , dtServerTracer - , dtInboundGovernorTracer - , dtInboundGovernorTransitionTracer - , dtLocalConnectionManagerTracer - , dtLocalServerTracer - , dtLocalInboundGovernorTracer - } - Arguments - { daIPv4Address - , daIPv6Address - , daLocalAddress - , daAcceptedConnectionsLimit - , daMode = diffusionMode - , daPublicPeerSelectionVar - } - ArgumentsExtra - { daPeerSelectionTargets - , daReadLocalRootPeers - , daReadPublicRootPeers - , daOwnPeerSharing - , daReadUseLedgerPeers - , daProtocolIdleTimeout - , daTimeWaitTimeout - , daDeadlineChurnInterval - , daBulkChurnInterval - , daReadLedgerPeerSnapshot - , daEmptyExtraState - , daEmptyExtraCounters - , daExtraPeersAPI - , daPeerSelectionGovernorArgs - , daPeerSelectionStateToExtraCounters - , daPeerChurnGovernor - , daToExtraPeers - , daRequestPublicRootPeers - , daExtraChurnArgs - , daMuxForkPolicy - , daLocalMuxForkPolicy - } - Applications - { daApplicationInitiatorMode - , daApplicationInitiatorResponderMode - , daLocalResponderApplication - , daLedgerPeersCtx - } - ApplicationsExtra - { daRethrowPolicy - , daLocalRethrowPolicy - , daReturnPolicy - , daPeerMetrics - , daPeerSharingRegistry - } - = do - -- Thread to which 'RethrowPolicy' will throw fatal exceptions. - mainThreadId <- myThreadId - - -- 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)) - ) - - where - (ledgerPeersRng, rng1) = split diRng - (policyRng, rng2) = split rng1 - (churnRng, rng3) = split rng2 - (fuzzRng, rng4) = split rng3 - (cmLocalStdGen, rng5) = split rng4 - (cmStdGen1, cmStdGen2) = split rng5 - - - mkInboundPeersMap :: IG.PublicState ntnAddr ntnVersionData - -> Map ntnAddr PeerSharing - mkInboundPeersMap - IG.PublicState { IG.inboundDuplexPeers } - = - Map.map diNtnPeerSharing inboundDuplexPeers - - -- TODO: this policy should also be used in `PeerStateActions` and - -- `InboundGovernor` (when creating or accepting connections) - rethrowPolicy = - -- Only the 'IOManagerError's are fatal, all the other exceptions in the - -- networking code will only shutdown the bearer (see 'ShutdownPeer' why - -- this is so). - RethrowPolicy (\_ctx err -> - case fromException err of - Just (_ :: IOManagerError) -> ShutdownNode - Nothing -> mempty) - <> - -- IOError rethrow-policy - -- - -- After a critical bug, we decided that `IOError` policy should only - -- kill the connection which thrown it. `IOError`s are not propagated. - -- There's a risk that one could arm an attack if one discovers - -- a mechanism to trigger fatal `IOError`s, e.g. through a kernel bug. - -- - -- It is responsibility for an SPO to monitor the node if it is making - -- progress and have enough resources to do so, e.g. if it has enough - -- memory, file descriptors. - -- - -- The `ouroboros-network` guarantees running on a fixed number of file - -- descriptors given a topology file, see - -- https://github.com/IntersectMBO/ouroboros-network/issues/4585#issuecomment-1591777447 - -- There's also a calculation for `ouroboros-consensus`, see - -- https://github.com/IntersectMBO/ouroboros-consensus/issues/20#issuecomment-1514554680 - -- File descriptors could be drained by the tracing system in - -- `cardano-node` (such a bug existed), or even an external process. - -- - RethrowPolicy (\_ctx err -> - case fromException err :: Maybe IOException of - Just {} -> mempty - Nothing -> mempty) - <> - RethrowPolicy (\ctx err -> case (ctx, fromException err) of - (OutboundError, Just Mx.UnknownMiniProtocol {}) - -> ShutdownPeer - _ -> mempty) - - - -- | 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 - localInbInfoChannel <- newInformationChannel - - let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 - - localConnectionHandler :: NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionHandler = - makeConnectionHandler - dtLocalMuxTracer - SingResponderMode - daLocalMuxForkPolicy - diNtcHandshakeArguments - ( ( \ (OuroborosApplication apps) - -> TemperatureBundle - (WithHot apps) - (WithWarm []) - (WithEstablished []) - ) <$> daLocalResponderApplication ) - (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) - - localConnectionManagerArguments - :: NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionManagerArguments = - CM.Arguments { - CM.tracer = dtLocalConnectionManagerTracer, - CM.trTracer = nullTracer, -- TODO: issue #3320 - CM.muxTracer = dtLocalMuxTracer, - CM.ipv4Address = Nothing, - CM.ipv6Address = Nothing, - CM.addressType = const Nothing, - CM.snocket = diNtcSnocket, - CM.makeBearer = diNtcBearer, - CM.configureSocket = \_ _ -> return (), - CM.timeWaitTimeout = local_TIME_WAIT_TIMEOUT, - CM.outboundIdleTimeout = local_PROTOCOL_IDLE_TIMEOUT, - CM.connectionDataFlow = ntcDataFlow, - CM.prunePolicy = Diffusion.Policies.prunePolicy, - CM.stdGen = cmLocalStdGen, - CM.connectionsLimits = localConnectionLimits, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply = diConnStateIdSupply - } - - CM.with - localConnectionManagerArguments - localConnectionHandler - classifyHandleError - (InResponderMode localInbInfoChannel) - $ \localConnectionManager-> do - -- - -- run node-to-client server - -- - traceWith tracer . RunLocalServer - =<< Snocket.getLocalAddr diNtcSnocket localSocket - - Server.with - Server.Arguments { - Server.sockets = localSocket :| [], - Server.snocket = diNtcSnocket, - Server.tracer = dtLocalServerTracer, - Server.trTracer = nullTracer, -- TODO: issue #3320 - Server.debugInboundGovernor = nullTracer, - Server.inboundGovernorTracer = dtLocalInboundGovernorTracer, - Server.inboundIdleTimeout = Nothing, - Server.connectionLimits = localConnectionLimits, - Server.connectionManager = localConnectionManager, - Server.connectionDataFlow = ntcDataFlow, - Server.inboundInfoChannel = localInbInfoChannel - } - (\inboundGovernorThread _ -> Async.wait inboundGovernorThread) - - - -- | mkRemoteThread - create remote connection manager - - mkRemoteThread :: ThreadId m -> m Void - mkRemoteThread mainThreadId = do - labelThisThread "remote connection manager" - let - exitPolicy :: ExitPolicy a - exitPolicy = stdExitPolicy daReturnPolicy - - ipv4Address - <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) - daIPv4Address - case ipv4Address of - Just addr | Just IPv4Address <- diNtnAddressType addr - -> pure () - | otherwise - -> throwIO (UnexpectedIPv4Address addr) - Nothing -> pure () - - ipv6Address - <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) - daIPv6Address - case ipv6Address of - Just addr | Just IPv6Address <- diNtnAddressType addr - -> pure () - | otherwise - -> throwIO (UnexpectedIPv6Address addr) - Nothing -> pure () - - lookupReqs <- case (ipv4Address, ipv6Address) of - (Just _ , Nothing) -> return LookupReqAOnly - (Nothing, Just _ ) -> return LookupReqAAAAOnly - (Just _ , Just _ ) -> return LookupReqAAndAAAA - (Nothing, Nothing) -> throwIO NoSocket - - -- RNGs used for picking random peers from the ledger and for - -- demoting/promoting peers. - policyRngVar <- newTVarIO policyRng - - localRootsVar <- newTVarIO mempty - - peerSelectionTargetsVar <- newTVarIO daPeerSelectionTargets - - countersVar <- newTVarIO (emptyPeerSelectionCounters daEmptyExtraCounters) - - -- Design notes: - -- - We split the following code into two parts: - -- - Part (a): plumb data flow (in particular arguments and tracersr) - -- and define common functions as a sequence of 'let's in which we - -- define needed 'withXXX' functions (and similar) which - -- - are used in Part (b), - -- - handle the plumbing of tracers, and - -- - capture commonalities between the two cases. - -- - -- - Part (b): capturing the major control-flow of runM: - -- in particular, two different case alternatives in which is captured - -- the monadic flow of the program stripped down to its essence: - --- ``` - -- - -- case diffusionMode of - -- InitiatorOnlyDiffusionMode -> ... - -- InitiatorAndResponderDiffusionMode -> ... - -- ``` - - -- - -- Part (a): plumb data flow and define common functions - -- - - let connectionManagerArguments' - :: forall handle handleError. - PrunePolicy ntnAddr - -> StdGen - -> CM.Arguments - (ConnectionHandlerTrace ntnVersion ntnVersionData) - ntnFd ntnAddr handle handleError ntnVersion ntnVersionData m - connectionManagerArguments' prunePolicy stdGen = - CM.Arguments { - CM.tracer = dtConnectionManagerTracer, - CM.trTracer = - fmap CM.abstractState - `contramap` dtConnectionManagerTransitionTracer, - CM.muxTracer = dtMuxTracer, - CM.ipv4Address, - CM.ipv6Address, - CM.addressType = diNtnAddressType, - CM.snocket = diNtnSnocket, - CM.makeBearer = diNtnBearer, - CM.configureSocket = diNtnConfigureSocket, - CM.connectionDataFlow = diNtnDataFlow, - CM.prunePolicy = prunePolicy, - CM.stdGen, - CM.connectionsLimits = daAcceptedConnectionsLimit, - CM.timeWaitTimeout = daTimeWaitTimeout, - CM.outboundIdleTimeout = daProtocolIdleTimeout, - CM.updateVersionData = diUpdateVersionData, - CM.connStateIdSupply = diConnStateIdSupply - } - - let peerSelectionPolicy = - simplePeerSelectionPolicy - policyRngVar daPeerMetrics (epErrorDelay exitPolicy) - - let makeConnectionHandler' - :: forall muxMode socket initiatorCtx responderCtx b c. - SingMuxMode muxMode - -> Versions ntnVersion ntnVersionData - (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) - -> MuxConnectionHandler - muxMode socket initiatorCtx responderCtx ntnAddr - ntnVersion ntnVersionData ByteString m b c - makeConnectionHandler' muxMode versions = - makeConnectionHandler - dtMuxTracer - muxMode - daMuxForkPolicy - diNtnHandshakeArguments - versions - (mainThreadId, rethrowPolicy <> daRethrowPolicy) - - -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of - -- withConnectionManager: - - withConnectionManagerInitiatorOnlyMode = - CM.with - (connectionManagerArguments' simplePrunePolicy cmStdGen1) - -- Server is not running, it will not be able to - -- advise which connections to prune. It's also not - -- expected that the governor targets will be larger - -- than limits imposed by 'cmConnectionsLimits'. - (makeConnectionHandler' - SingInitiatorMode - daApplicationInitiatorMode) - classifyHandleError - NotInResponderMode - - withConnectionManagerInitiatorAndResponderMode - inbndInfoChannel = - CM.with - (connectionManagerArguments' Diffusion.Policies.prunePolicy cmStdGen2) - (makeConnectionHandler' - SingInitiatorResponderMode - daApplicationInitiatorResponderMode) - classifyHandleError - (InResponderMode inbndInfoChannel) - - -- - -- peer state actions - -- - -- Peer state actions run a job pool in the background which - -- tracks threads forked by 'PeerStateActions' - -- - - let -- | parameterized version of 'withPeerStateActions' - withPeerStateActions' - :: forall (muxMode :: Mx.Mode) responderCtx socket b c. - HasInitiator muxMode ~ True - => MuxConnectionManager - muxMode socket (ExpandedInitiatorContext ntnAddr m) - responderCtx ntnAddr ntnVersionData ntnVersion - ByteString m a b - -> (Governor.PeerStateActions - ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr - ntnVersionData ByteString m a b) - m - -> m c) - -> m c - withPeerStateActions' connectionManager = - withPeerStateActions - PeerStateActionsArguments { - spsTracer = dtPeerSelectionActionsTracer, - spsDeactivateTimeout = Diffusion.Policies.deactivateTimeout, - spsCloseConnectionTimeout = - Diffusion.Policies.closeConnectionTimeout, - spsConnectionManager = connectionManager, - spsExitPolicy = exitPolicy, - spsRethrowPolicy = rethrowPolicy, - spsMainThreadId = mainThreadId - } - - dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore - let dnsActions = - PeerActionsDNS { - paToPeerAddr = diNtnToPeerAddr - , paDnsActions = diDnsActions lookupReqs - } - -- - -- Run peer selection (p2p governor) - -- - let - withPeerSelectionActions' - :: m (Map ntnAddr PeerSharing) - -> PeerStateActions - ntnAddr - (PeerConnectionHandle - muxMode responderCtx ntnAddr ntnVersionData bytes m a b) - m - -> ((Async m Void, Async m Void) - -> PeerSelectionActions - extraState - extraFlags - extraPeers - extraAPI - extraCounters - ntnAddr - (PeerConnectionHandle - muxMode responderCtx ntnAddr ntnVersionData bytes m a b) - m - -> m c) - -> m c - withPeerSelectionActions' readInboundPeers peerStateActions = - withPeerSelectionActions dtTraceLocalRootPeersTracer - localRootsVar - dnsActions - (\getLedgerPeers -> PeerSelectionActions { - peerSelectionTargets = daPeerSelectionTargets, - readPeerSelectionTargets = readTVar peerSelectionTargetsVar, - getLedgerStateCtx = daLedgerPeersCtx, - readLocalRootPeersFromFile = daReadLocalRootPeers, - readLocalRootPeers = readTVar localRootsVar, - peerSharing = daOwnPeerSharing, - peerConnToPeerSharing = pchPeerSharing diNtnPeerSharing, - requestPeerShare = - requestPeerSharingResult (readTVar (getPeerSharingRegistry daPeerSharingRegistry)), - requestPublicRootPeers = - case daRequestPublicRootPeers of - Nothing -> - Ouroboros.requestPublicRootPeers - dtTracePublicRootPeersTracer - daReadPublicRootPeers - dnsActions - dnsSemaphore - daToExtraPeers - getLedgerPeers - Just requestPublicRootPeers' -> - requestPublicRootPeers' dnsActions dnsSemaphore daToExtraPeers getLedgerPeers, - readInboundPeers = - case daOwnPeerSharing of - PeerSharingDisabled -> pure Map.empty - PeerSharingEnabled -> readInboundPeers, - readLedgerPeerSnapshot = daReadLedgerPeerSnapshot, - extraPeersAPI = daExtraPeersAPI, - extraStateToExtraCounters = daPeerSelectionStateToExtraCounters, - peerStateActions - }) - WithLedgerPeersArgs { - wlpRng = ledgerPeersRng, - wlpConsensusInterface = daLedgerPeersCtx, - wlpTracer = dtTraceLedgerPeersTracer, - wlpGetUseLedgerPeers = daReadUseLedgerPeers, - wlpGetLedgerPeerSnapshot = daReadLedgerPeerSnapshot, - wlpSemaphore = dnsSemaphore - } - - peerSelectionGovernor' - :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) - -> StrictTVar m (PeerSelectionState extraState extraFlags extraPeers ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData ByteString m a b)) - -> PeerSelectionActions - extraState extraFlags extraPeers - extraAPI extraCounters ntnAddr - (PeerConnectionHandle muxMode responderCtx ntnAddr ntnVersionData ByteString m a b) - m - -> m Void - peerSelectionGovernor' peerSelectionTracer dbgVar peerSelectionActions = - Governor.peerSelectionGovernor - dtTracePeerSelectionTracer - peerSelectionTracer - dtTracePeerSelectionCounters - daPeerSelectionGovernorArgs - fuzzRng - daEmptyExtraState - mempty - peerSelectionActions - peerSelectionPolicy - PeerSelectionInterfaces { - countersVar, - publicStateVar = daPublicPeerSelectionVar, - debugStateVar = dbgVar, - readUseLedgerPeers = daReadUseLedgerPeers - } - - - -- - -- The peer churn governor: - -- - let peerChurnGovernor' = - daPeerChurnGovernor - PeerChurnArgs { - pcaPeerSelectionTracer = dtTracePeerSelectionTracer - , pcaChurnTracer = dtTraceChurnCounters - , pcaDeadlineInterval = daDeadlineChurnInterval - , pcaBulkInterval = daBulkChurnInterval - , pcaPeerRequestTimeout = policyPeerShareOverallTimeout peerSelectionPolicy - , pcaMetrics = daPeerMetrics - , pcaRng = churnRng - , pcaPeerSelectionVar = peerSelectionTargetsVar - , pcaReadCounters = readTVar countersVar - , getLedgerStateCtx = daLedgerPeersCtx - , getLocalRootHotTarget = - LocalRootPeers.hotTarget - . LocalRootPeers.fromGroups - <$> readTVar localRootsVar - , getOriginalPeerTargets = daPeerSelectionTargets - , getExtraArgs = daExtraChurnArgs - } - - -- - -- Two functions only used in InitiatorAndResponder mode - -- - let - -- create sockets - withSockets' f = - withSockets tracer diNtnSnocket - (\sock addr -> diNtnConfigureSocket sock (Just addr)) - (\sock addr -> diNtnConfigureSystemdSocket sock addr) - ( catMaybes - [ daIPv4Address - , daIPv6Address - ] - ) - f - - -- run node-to-node server - withServer sockets connectionManager inboundInfoChannel = - Server.with - Server.Arguments { - Server.sockets = sockets, - Server.snocket = diNtnSnocket, - Server.tracer = dtServerTracer, - Server.trTracer = dtInboundGovernorTransitionTracer, - Server.debugInboundGovernor = nullTracer, - Server.inboundGovernorTracer = dtInboundGovernorTracer, - Server.connectionLimits = daAcceptedConnectionsLimit, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = diNtnDataFlow, - Server.inboundIdleTimeout = Just daProtocolIdleTimeout, - Server.inboundInfoChannel = inboundInfoChannel - } - - -- - -- Part (b): capturing the major control-flow of runM: - -- - case diffusionMode of - - -- InitiatorOnly mode, run peer selection only: - InitiatorOnlyDiffusionMode -> - withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do - debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng daEmptyExtraState mempty - diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics - withPeerStateActions' connectionManager $ \peerStateActions-> - withPeerSelectionActions' - (return Map.empty) - peerStateActions $ - \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions-> - Async.withAsync - (peerSelectionGovernor' - dtDebugPeerSelectionInitiatorTracer - debugStateVar - peerSelectionActions) $ \governorThread -> - Async.withAsync - peerChurnGovernor' $ \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny - [ledgerPeersThread, localRootPeersProvider, governorThread, churnGovernorThread] - - -- InitiatorAndResponder mode, run peer selection and the server: - InitiatorAndResponderDiffusionMode -> do - inboundInfoChannel <- newInformationChannel - withConnectionManagerInitiatorAndResponderMode - inboundInfoChannel $ \connectionManager -> - -- - -- node-to-node sockets - -- - withSockets' $ \sockets addresses -> do - -- - -- node-to-node server - -- - withServer sockets connectionManager inboundInfoChannel $ - \inboundGovernorThread readInboundState -> do - debugStateVar <- newTVarIO $ emptyPeerSelectionState fuzzRng daEmptyExtraState mempty - diInstallSigUSR1Handler connectionManager debugStateVar daPeerMetrics - withPeerStateActions' connectionManager $ - \peerStateActions -> - withPeerSelectionActions' - (mkInboundPeersMap <$> readInboundState) - peerStateActions $ - \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> - Async.withAsync - (do - labelThisThread "Peer selection governor" - peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ - \governorThread -> do - -- begin, unique to InitiatorAndResponder mode: - traceWith tracer (RunServer addresses) - -- end, unique to ... - Async.withAsync (do - labelThisThread "Peer churn governor" - peerChurnGovernor') $ - \churnGovernorThread -> - -- wait for any thread to fail: - snd <$> Async.waitAny [ ledgerPeersThread - , localRootPeersProvider - , governorThread - , churnGovernorThread - , inboundGovernorThread - ] - --- | Main entry point for data diffusion service. It allows to: --- --- * connect to upstream peers; --- * accept connection from downstream peers, if run in --- 'InitiatorAndResponderDiffusionMode'. --- * runs a local service which allows to use node-to-client protocol to obtain --- information from the running system. This is used by 'cardano-cli' or --- a wallet and a like local services. --- -run :: ( Monoid extraPeers - , Eq extraFlags - , Eq extraCounters - , Exception exception - ) - => ( forall (mode :: Mx.Mode) x y. - NodeToNodeConnectionManager mode Socket - RemoteAddress NodeToNodeVersionData - NodeToNodeVersion IO x y - -> StrictTVar IO - (PeerSelectionState extraState extraFlags extraPeers - RemoteAddress - (NodeToNodePeerConnectionHandle - mode RemoteAddress - NodeToNodeVersionData IO x y)) - -> PeerMetrics IO RemoteAddress - -> IO ()) - -> Tracers - RemoteAddress - NodeToNodeVersion - LocalAddress - NodeToClientVersion - IO - -> TracersExtra - RemoteAddress - NodeToNodeVersion - NodeToNodeVersionData - LocalAddress - NodeToClientVersion - NodeToClientVersionData - IOException - extraState - extraDebugState - extraFlags - extraPeers - extraCounters - IO - -> Arguments - IO - Socket - RemoteAddress - LocalSocket - LocalAddress - -> ArgumentsExtra - extraState - extraDebugState - extraFlags - extraPeers - extraAPI - extraChurnArgs - extraCounters - exception - RemoteAddress - LocalAddress - Resolver - IOException - IO - -> Applications - RemoteAddress - NodeToNodeVersion - NodeToNodeVersionData - LocalAddress - NodeToClientVersion - NodeToClientVersionData - extraAPI - IO - a - -> ApplicationsExtra - RemoteAddress - IO - a - -> IO Void -run sigUSR1Signal tracers tracersExtra args argsExtra apps appsExtra = do - let tracer = dtDiffusionTracer tracers - diNtnHandshakeArguments = - HandshakeArguments { - haHandshakeTracer = dtHandshakeTracer tracers, - haHandshakeCodec = NodeToNode.nodeToNodeHandshakeCodec, - haVersionDataCodec = - cborTermVersionDataCodec - NodeToNode.nodeToNodeCodecCBORTerm, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = timeLimitsHandshake - } - diNtcHandshakeArguments = - HandshakeArguments { - haHandshakeTracer = dtLocalHandshakeTracer tracers, - haHandshakeCodec = NodeToClient.nodeToClientHandshakeCodec, - haVersionDataCodec = - cborTermVersionDataCodec - NodeToClient.nodeToClientCodecCBORTerm, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = noTimeLimitsHandshake - } - - diRng <- newStdGen - diConnStateIdSupply <- atomically $ newConnStateIdSupply Proxy - - -- We run two services: for /node-to-node/ and /node-to-client/. The - -- naming convention is that we use /local/ prefix for /node-to-client/ - -- related terms, as this is a local only service running over a unix - -- socket / windows named pipe. - handleJust (\e -> case fromException e :: Maybe ExitCode of - Nothing -> Just e - Just {} -> Nothing) - (\e -> traceWith tracer (DiffusionErrored e) - >> throwIO (DiffusionError e)) - $ withIOManager $ \iocp -> do - runM - Interfaces { - diNtnSnocket = Snocket.socketSnocket iocp, - diNtnBearer = makeSocketBearer, - diNtnConfigureSocket = configureSocket, - diNtnConfigureSystemdSocket = - configureSystemdSocket - (SystemdSocketConfiguration `contramap` tracer), - diNtnAddressType = socketAddressType, - diNtnDataFlow = ntnDataFlow, - diNtnPeerSharing = peerSharing, - diNtnToPeerAddr = curry IP.toSockAddr, - diNtcSnocket = Snocket.localSnocket iocp, - diNtcBearer = makeLocalBearer, - diNtcGetFileDescriptor = localSocketFileDescriptor, - diDnsActions = ioDNSActions, - diInstallSigUSR1Handler = sigUSR1Signal, - diNtnHandshakeArguments, - diNtcHandshakeArguments, - diRng, - diUpdateVersionData = \versionData diffusionMode -> versionData { diffusionMode }, - diConnStateIdSupply - } - tracers tracersExtra args argsExtra apps appsExtra - - --- --- Data flow --- - --- | Node-To-Node protocol connections which negotiated --- `InitiatorAndResponderDiffusionMode` are `Duplex`. --- -ntnDataFlow :: NodeToNodeVersionData -> DataFlow -ntnDataFlow NodeToNodeVersionData { diffusionMode } = - case diffusionMode of - InitiatorAndResponderDiffusionMode -> Duplex - InitiatorOnlyDiffusionMode -> Unidirectional - - --- | All Node-To-Client protocol connections are considered 'Unidirectional'. --- -ntcDataFlow :: ntcVersionData -> DataFlow -ntcDataFlow _ = Unidirectional diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs new file mode 100644 index 00000000000..14e9494066b --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -0,0 +1,699 @@ +-- Common things between P2P and NonP2P Diffusion modules +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Network.Diffusion.Types + ( DiffusionTracer (..) + , Failure (..) + , Tracers (..) + , nullTracers + , Arguments (..) + , Applications (..) + , Interfaces (..) + -- * ForkPolicy + , Mx.ForkPolicy + , Mx.noBindForkPolicy + , Mx.responderForkPolicy + -- * NodeToClient type aliases + , NodeToClientHandle + , NodeToClientHandleError + , NodeToClientConnectionHandler + , NodeToClientConnectionManagerArguments + -- * NodeToNode type aliases + , NodeToNodeHandle + , NodeToNodeConnectionManager + , NodeToNodePeerConnectionHandle + , NodeToNodePeerSelectionActions + -- * Re-exports + , AbstractTransitionTrace + , IG.RemoteTransitionTrace + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (Exception, SomeException) +import Control.Monad.Class.MonadTimer.SI +import Control.Tracer (Tracer, nullTracer) + +import Data.ByteString.Lazy (ByteString) +import Data.IP (IP) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Set (Set) +import Data.Typeable (Typeable) +import Data.Void (Void) +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 (..)) + +import Ouroboros.Network.ConnectionHandler +import Ouroboros.Network.ConnectionManager.Core qualified as CM +import Ouroboros.Network.ConnectionManager.State qualified as CM +import Ouroboros.Network.ConnectionManager.Types +import Ouroboros.Network.Context +import Ouroboros.Network.ExitPolicy +import Ouroboros.Network.InboundGovernor qualified as IG +import Ouroboros.Network.Mux qualified as Mx +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments, Versions) +import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Snocket (FileDescriptor, Snocket) +import Ouroboros.Network.Socket (SystemdSocketTracer) + +import Ouroboros.Network.NodeToClient qualified as NodeToClient +import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit, DiffusionMode) +import Ouroboros.Network.NodeToNode qualified as NodeToNode +import Ouroboros.Network.PeerSelection.Churn qualified as Governor +import Ouroboros.Network.PeerSelection.Governor.Types +import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeerSnapshot, + LedgerPeersConsensusInterface (..), LedgerPeersKind, NumberOfPeers, + TraceLedgerPeers, UseLedgerPeers) +import Ouroboros.Network.PeerSelection.PeerAdvertise +import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics) +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.PeerStateActions (PeerConnectionHandle, + PeerSelectionActionsTrace) +import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS (PeerActionsDNS) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers +import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI) + +-- | The 'DiffusionTracer' logs +-- +-- * diffusion initialisation messages +-- * terminal errors thrown by diffusion +-- +data DiffusionTracer ntnAddr ntcAddr + = RunServer (NonEmpty ntnAddr) + | RunLocalServer ntcAddr + | UsingSystemdSocket ntcAddr + -- Rename as 'CreateLocalSocket' + | CreateSystemdSocketForSnocketPath ntcAddr + | CreatedLocalSocket ntcAddr + | ConfiguringLocalSocket ntcAddr FileDescriptor + | ListeningLocalSocket ntcAddr FileDescriptor + | LocalSocketUp ntcAddr FileDescriptor + -- Rename as 'CreateServerSocket' + | CreatingServerSocket ntnAddr + | ConfiguringServerSocket ntnAddr + | ListeningServerSocket ntnAddr + | ServerSocketUp ntnAddr + -- Rename as 'UnsupportedLocalSocketType' + | UnsupportedLocalSystemdSocket ntnAddr + -- Remove (this is impossible case), there's no systemd on Windows + | UnsupportedReadySocketCase + | DiffusionErrored SomeException + | SystemdSocketConfiguration SystemdSocketTracer + deriving Show + +-- TODO: add a tracer for these misconfiguration +data Failure where + UnsupportedReadySocket :: Failure + UnexpectedIPv4Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure + UnexpectedIPv6Address :: forall ntnAddr. (Show ntnAddr, Typeable ntnAddr) => ntnAddr -> Failure + NoSocket :: Failure + DiffusionError :: SomeException -> Failure + +deriving instance Show Failure +instance Exception Failure + +-- | Common DiffusionTracers interface between P2P and NonP2P +-- +data Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError extraState extraDebugState + extraFlags extraPeers extraCounters m = Tracers { + -- | Mux tracer + dtMuxTracer + :: Tracer m (Mx.WithBearer (ConnectionId ntnAddr) Mx.Trace) + + -- | Handshake protocol tracer + , dtHandshakeTracer + :: Tracer m (NodeToNode.HandshakeTr ntnAddr ntnVersion) + + -- + -- NodeToClient tracers + -- + + -- | Mux tracer for local clients + , dtLocalMuxTracer + :: Tracer m (Mx.WithBearer (ConnectionId ntcAddr) Mx.Trace) + + -- | Handshake protocol tracer for local clients + , dtLocalHandshakeTracer + :: Tracer m (NodeToClient.HandshakeTr ntcAddr ntcVersion) + + -- | Diffusion initialisation tracer + , dtDiffusionTracer + :: Tracer m (DiffusionTracer ntnAddr ntcAddr) + + , dtTraceLocalRootPeersTracer + :: Tracer m (TraceLocalRootPeers extraFlags ntnAddr resolverError) + + , dtTracePublicRootPeersTracer + :: Tracer m TracePublicRootPeers + + -- | Ledger Peers tracer + , dtTraceLedgerPeersTracer + :: Tracer m TraceLedgerPeers + + , dtTracePeerSelectionTracer + :: Tracer m (TracePeerSelection extraDebugState extraFlags extraPeers ntnAddr) + + , dtDebugPeerSelectionInitiatorTracer + :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) + + -- TODO: can be unified with the previous one + , dtDebugPeerSelectionInitiatorResponderTracer + :: Tracer m (DebugPeerSelection extraState extraFlags extraPeers ntnAddr) + + , dtTracePeerSelectionCounters + :: Tracer m (PeerSelectionCounters extraCounters) + + , dtTraceChurnCounters + :: Tracer m Governor.ChurnCounters + + , dtPeerSelectionActionsTracer + :: Tracer m (PeerSelectionActionsTrace ntnAddr ntnVersion) + + , dtConnectionManagerTracer + :: Tracer m (CM.Trace + ntnAddr + (ConnectionHandlerTrace + ntnVersion + ntnVersionData)) + + , dtConnectionManagerTransitionTracer + :: Tracer m (AbstractTransitionTrace CM.ConnStateId) + + , dtServerTracer + :: Tracer m (Server.Trace ntnAddr) + + , dtInboundGovernorTracer + :: Tracer m (IG.Trace ntnAddr) + + , dtInboundGovernorTransitionTracer + :: Tracer m (IG.RemoteTransitionTrace ntnAddr) + + -- + -- NodeToClient tracers + -- + + -- | Connection manager tracer for local clients + , dtLocalConnectionManagerTracer + :: Tracer m (CM.Trace + ntcAddr + (ConnectionHandlerTrace + ntcVersion + ntcVersionData)) + + -- | Server tracer for local clients + , dtLocalServerTracer + :: Tracer m (Server.Trace ntcAddr) + + -- | Inbound protocol governor tracer for local clients + , dtLocalInboundGovernorTracer + :: Tracer m (IG.Trace ntcAddr) + } + + +nullTracers :: Applicative m + => Tracers ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + resolverError extraState extraDebugState + extraFlags extraPeers extraCounters m +nullTracers = Tracers { + dtMuxTracer = nullTracer + , dtHandshakeTracer = nullTracer + , dtLocalMuxTracer = nullTracer + , dtLocalHandshakeTracer = nullTracer + , dtDiffusionTracer = nullTracer + , dtTraceLocalRootPeersTracer = nullTracer + , dtTracePublicRootPeersTracer = nullTracer + , dtTraceLedgerPeersTracer = nullTracer + , dtTracePeerSelectionTracer = nullTracer + , dtTraceChurnCounters = nullTracer + , dtDebugPeerSelectionInitiatorTracer = nullTracer + , dtDebugPeerSelectionInitiatorResponderTracer = nullTracer + , dtTracePeerSelectionCounters = nullTracer + , dtPeerSelectionActionsTracer = nullTracer + , dtConnectionManagerTracer = nullTracer + , dtConnectionManagerTransitionTracer = nullTracer + , dtServerTracer = nullTracer + , dtInboundGovernorTracer = nullTracer + , dtInboundGovernorTransitionTracer = nullTracer + , dtLocalConnectionManagerTracer = nullTracer + , dtLocalServerTracer = nullTracer + , dtLocalInboundGovernorTracer = nullTracer + } + +-- | Common DiffusionArguments interface between P2P and NonP2P +-- +data Arguments extraState extraDebugState extraFlags extraPeers + extraAPI extraChurnArgs extraCounters exception + resolver resolverError + m ntnFd ntnAddr ntcFd ntcAddr = Arguments { + -- | an @IPv4@ socket ready to accept connections or an @IPv4@ addresses + -- + daIPv4Address :: Maybe (Either ntnFd ntnAddr) + + -- | an @IPv6@ socket ready to accept connections or an @IPv6@ addresses + -- + , daIPv6Address :: Maybe (Either ntnFd ntnAddr) + + -- | an @AF_UNIX@ socket ready to accept connections or an @AF_UNIX@ + -- socket path + , daLocalAddress :: Maybe (Either ntcFd ntcAddr) + + -- | parameters for limiting number of accepted connections + -- + , daAcceptedConnectionsLimit :: AcceptedConnectionsLimit + + -- | run in initiator only mode + -- + , daMode :: DiffusionMode + + -- | public peer selection state + -- + -- It is created outside of diffusion, since it is needed to create some + -- apps (e.g. peer sharing). + -- + , daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState ntnAddr) + + -- | selection targets for the peer governor + -- + , daPeerSelectionTargets :: PeerSelectionTargets + , daReadLocalRootPeers :: STM m (LocalRootPeers.Config extraFlags RelayAccessPoint) + , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise) + + -- | Depending on configuration, node may provide us with + -- a snapshot of big ledger peers taken at some slot on the chain. + -- These peers may be selected by ledgerPeersThread when requested + -- by the peer selection governor when the node is syncing up. + -- This is especially useful for Genesis consensus mode. + , daReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) + + -- | Peer's own PeerSharing value. + -- + -- This value comes from the node's configuration file and is static. + , daOwnPeerSharing :: PeerSharing + , daReadUseLedgerPeers :: STM m UseLedgerPeers + + -- | Timeout which starts once all responder protocols are idle. If the + -- responders stay idle for duration of the timeout, the connection will + -- be demoted, if it wasn't used by the p2p-governor it will be closed. + -- + -- Applies to 'Unidirectional' as well as 'Duplex' /node-to-node/ + -- connections. + -- + -- See 'serverProtocolIdleTimeout'. + -- + , daProtocolIdleTimeout :: DiffTime + + -- | Time for which /node-to-node/ connections are kept in + -- 'TerminatingState', it should correspond to the OS configured @TCP@ + -- @TIME_WAIT@ timeout. + -- + -- This timeout will apply to after a connection has been closed, its + -- purpose is to be resilient for delayed packets in the same way @TCP@ + -- is using @TIME_WAIT@. + -- + , daTimeWaitTimeout :: DiffTime + + -- | Churn interval between churn events in deadline mode. A small fuzz + -- is added (max 10 minutes) so that not all nodes churn at the same time. + -- + -- By default it is set to 3300 seconds. + -- + , daDeadlineChurnInterval :: DiffTime + + -- | Churn interval between churn events in bulk sync mode. A small fuzz + -- is added (max 1 minute) so that not all nodes churn at the same time. + -- + -- By default it is set to 300 seconds. + -- + , daBulkChurnInterval :: DiffTime + + -- | Extra State empty value + -- + , daEmptyExtraState :: extraState + + -- | Extra Counters empty value + -- + , daEmptyExtraCounters :: extraCounters + + -- | Provide Public Extra Actions for extraPeers to be + -- + , daExtraPeersAPI :: PublicExtraPeersAPI extraPeers ntnAddr + + , daPeerSelectionGovernorArgs + :: forall muxMode responderCtx ntnVersionData bytes a b . + PeerSelectionGovernorArgs extraState extraDebugState extraFlags extraPeers + extraAPI extraCounters + ntnAddr (PeerConnectionHandle + muxMode responderCtx ntnAddr + ntnVersionData bytes m a b) + exception m + + -- | Function that computes extraCounters from PeerSelectionState + -- + , daPeerSelectionStateToExtraCounters + :: forall muxMode responderCtx ntnVersionData bytes a b . + PeerSelectionState extraState extraFlags extraPeers + ntnAddr (PeerConnectionHandle + muxMode responderCtx ntnAddr + ntnVersionData bytes m a b) + -> extraCounters + + -- | Function that constructs a 'extraPeers' set from a map of dns + -- lookup results. + -- + , daToExtraPeers :: Map ntnAddr PeerAdvertise -> extraPeers + + -- | Request Public Root Peers. + -- + -- If no custom public root peers is provided (i.e. Nothing) just the + -- default one from + -- 'Ouroboros.Network.PeerSelection.PeerSelectionActions.getPublicRootPeers' + -- + , daRequestPublicRootPeers + :: Maybe ( PeerActionsDNS ntnAddr resolver resolverError m + -> DNSSemaphore m + -> (Map ntnAddr PeerAdvertise -> extraPeers) + -> ( (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set ntnAddr, DiffTime))) + -> LedgerPeersKind + -> Int + -> m (PublicRootPeers extraPeers ntnAddr, DiffTime))) + + -- | Peer Churn Governor if no custom churn governor is required just + -- use the default one from + -- 'Ouroboros.Network.PeerSelection.Churn.peerChurnGovernor' + -- + , daPeerChurnGovernor + :: Governor.PeerChurnArgs + m + extraChurnArgs + extraDebugState + extraFlags + extraPeers + extraAPI + extraCounters + ntnAddr + -> m Void + + -- | Provide extraChurnArgs to be passed to churn governor + -- + , daExtraChurnArgs :: extraChurnArgs + + -- | A fork policy for node-to-node mini-protocol threads spawn by mux. + -- + , daMuxForkPolicy :: Mx.ForkPolicy ntnAddr + + -- | A fork policy for node-to-client mini-protocols threads spawn by mux. + -- + , daLocalMuxForkPolicy :: Mx.ForkPolicy ntcAddr + + } + + +-- | Versioned mini-protocol bundles run on a negotiated connection. +-- +data Applications ntnAddr ntnVersion ntnVersionData + ntcAddr ntcVersion ntcVersionData + extraAPI m a = + Applications { + -- | NodeToNode initiator applications for initiator only mode. + -- + -- TODO: we should accept one or the other, but not both: + -- 'daApplicationInitiatorMode', 'daApplicationInitiatorResponderMode'. + -- + -- Even in non-p2p mode we use p2p apps. + daApplicationInitiatorMode + :: Versions ntnVersion + ntnVersionData + (OuroborosBundleWithExpandedCtx + Mx.InitiatorMode ntnAddr + ByteString m a Void) + + -- | NodeToNode initiator & responder applications for bidirectional mode. + -- + , daApplicationInitiatorResponderMode + -- Peer Sharing result computation callback + :: Versions ntnVersion + ntnVersionData + (OuroborosBundleWithExpandedCtx + Mx.InitiatorResponderMode ntnAddr + ByteString m a ()) + + -- | NodeToClient responder application (server role) + -- + -- Because p2p mode does not infect local connections we we use non-p2p + -- apps. + , daLocalResponderApplication + :: Versions ntcVersion + ntcVersionData + (OuroborosApplicationWithMinimalCtx + Mx.ResponderMode ntcAddr + ByteString m Void ()) + + -- | Interface used to get peers from the current ledger. + -- + -- TODO: it should be in 'InterfaceExtra' + , daLedgerPeersCtx :: LedgerPeersConsensusInterface extraAPI m + + -- | /node-to-node/ rethrow policy + -- + , daRethrowPolicy :: RethrowPolicy + + -- | /node-to-node/ return policy + -- + , daReturnPolicy :: ReturnPolicy a + + -- | /node-to-client/ rethrow policy + -- + , daLocalRethrowPolicy :: RethrowPolicy + + -- | 'PeerMetrics' used by peer selection policy (see + -- 'simplePeerSelectionPolicy') + -- + , daPeerMetrics :: PeerMetrics m ntnAddr + + -- | Used by churn-governor + -- + , daBlockFetchMode :: STM m FetchMode + + -- | Used for peer sharing protocol + -- + , daPeerSharingRegistry :: PeerSharingRegistry ntnAddr m + } + + +-- +-- Node-To-Client type aliases +-- +-- Node-To-Client diffusion is only used in 'ResponderMode'. +-- + +type NodeToClientHandle ntcAddr versionData m = + HandleWithMinimalCtx Mx.ResponderMode ntcAddr versionData ByteString m Void () + +type NodeToClientHandleError ntcVersion = + HandleError Mx.ResponderMode ntcVersion + +type NodeToClientConnectionHandler + ntcFd ntcAddr ntcVersion ntcVersionData m = + ConnectionHandler + Mx.ResponderMode + (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd + ntcAddr + (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandleError ntcVersion) + ntcVersion + ntcVersionData + m + +type NodeToClientConnectionManagerArguments + ntcFd ntcAddr ntcVersion ntcVersionData m = + CM.Arguments + (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd + ntcAddr + (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandleError ntcVersion) + ntcVersion + ntcVersionData + m + + +-- +-- Node-To-Node type aliases +-- +-- Node-To-Node diffusion runs in either 'InitiatorMode' or 'InitiatorResponderMode'. +-- + +type NodeToNodeHandle + (mode :: Mx.Mode) + ntnAddr ntnVersionData m a b = + HandleWithExpandedCtx mode ntnAddr ntnVersionData ByteString m a b + +type NodeToNodeConnectionManager + (mode :: Mx.Mode) + ntnFd ntnAddr ntnVersionData ntnVersion m a b = + ConnectionManager + mode + ntnFd + ntnAddr + (NodeToNodeHandle mode ntnAddr ntnVersionData m a b) + (HandleError mode ntnVersion) + m + +-- +-- Governor type aliases +-- + +type NodeToNodePeerConnectionHandle (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = + PeerConnectionHandle + mode + (ResponderContext ntnAddr) + ntnAddr + ntnVersionData + ByteString + m a b + +type NodeToNodePeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters + (mode :: Mx.Mode) ntnAddr ntnVersionData m a b = + PeerSelectionActions + extraState extraFlags extraPeers extraAPI extraCounters + ntnAddr + (NodeToNodePeerConnectionHandle mode ntnAddr ntnVersionData m a b) + m + + +data Interfaces ntnFd ntnAddr ntnVersion ntnVersionData + ntcFd ntcAddr ntcVersion ntcVersionData + resolver resolverError + extraState extraFlags extraPeers extraAPI + m = + Interfaces { + -- | node-to-node snocket + -- + diNtnSnocket + :: Snocket m ntnFd ntnAddr, + + -- | node-to-node 'Mx.MakeBearer' callback + -- + diNtnBearer + :: Mx.MakeBearer m ntnFd, + + -- | node-to-node socket configuration + -- + diNtnConfigureSocket + :: ntnFd -> Maybe ntnAddr -> m (), + + -- | node-to-node systemd socket configuration + -- + diNtnConfigureSystemdSocket + :: ntnFd -> ntnAddr -> m (), + + -- | node-to-node handshake configuration + -- + diNtnHandshakeArguments + :: HandshakeArguments (ConnectionId ntnAddr) ntnVersion ntnVersionData m, + + -- | node-to-node address type + -- + diNtnAddressType + :: ntnAddr -> Maybe AddressType, + + -- | node-to-node data flow used by connection manager to classify + -- negotiated connections + -- + diNtnDataFlow + :: ntnVersionData -> DataFlow, + + -- | remote side peer sharing information used by peer selection governor + -- to decide which peers are available for performing peer sharing + diNtnPeerSharing + :: ntnVersionData -> PeerSharing, + + -- | node-to-node peer address + -- + diNtnToPeerAddr + :: IP -> Socket.PortNumber -> ntnAddr, + + -- | node-to-client snocket + -- + diNtcSnocket + :: Snocket m ntcFd ntcAddr, + + -- | node-to-client 'Mx.MakeBearer' callback + -- + diNtcBearer + :: Mx.MakeBearer m ntcFd, + + -- | node-to-client handshake configuration + -- + diNtcHandshakeArguments + :: HandshakeArguments (ConnectionId ntcAddr) ntcVersion ntcVersionData m, + + -- | node-to-client file descriptor + -- + diNtcGetFileDescriptor + :: ntcFd -> m FileDescriptor, + + -- | diffusion pseudo random generator. It is split between various + -- components that need randomness, e.g. inbound governor, peer + -- selection, policies, etc. + -- + diRng + :: StdGen, + + -- | callback which is used to register @SIGUSR1@ signal handler. + diInstallSigUSR1Handler + :: forall mode x y. + NodeToNodeConnectionManager mode ntnFd + ntnAddr ntnVersionData + ntnVersion m x y + -> StrictTVar m + (PeerSelectionState extraState extraFlags extraPeers + ntnAddr + (NodeToNodePeerConnectionHandle + mode ntnAddr + ntnVersionData m x y)) + -> PeerMetrics m ntnAddr + -> m (), + + -- | diffusion dns actions + -- + diDnsActions + :: DNSLookupType -> DNSActions resolver resolverError m, + + -- | Update `ntnVersionData` for initiator-only local roots. + diUpdateVersionData + :: ntnVersionData -> DiffusionMode -> ntnVersionData, + + -- | `ConnStateIdSupply` used by the connection-manager for this node. + -- + -- This is exposed for testing, where we use a global + -- `ConnStateIdSupply`. + -- + diConnStateIdSupply + :: CM.ConnStateIdSupply m + } diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs index bcab690a202..aeee341aba3 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Utils.hs @@ -21,7 +21,7 @@ import Data.Typeable (Typeable) import Ouroboros.Network.Snocket (FileDescriptor, Snocket) import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Diffusion.Common +import Ouroboros.Network.Diffusion.Types -- -- Socket utility functions From 468770efaf8c86821e2e672fcee4ba3fd4e4b93f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 4 Nov 2024 08:41:53 +0100 Subject: [PATCH 2/6] ouroboros-network-framework: removed various NonP2P components * `Ouroboros.Network.Subscription` removed; * `Ouroboros.Network.ErrorPolicy` removed; * APIs removed from `Ouroboros.Network.Socket`: * `NetworkMutableState` & friends, * `withServerNode` and `withServerNode'`, * `NetworkServerTracers`, * `fromSnocket`, * `beginConnection` * `Ouroboros.Network.Server.Socket` replaced with a simpler server implementation in `Test.Ouroboros.Network.Server`. All tests & demos of `ouroboros-network-framework` update. --- ouroboros-network-framework/CHANGELOG.md | 10 + ouroboros-network-framework/demo/ping-pong.hs | 49 +- ouroboros-network-framework/io-tests/Main.hs | 4 +- .../io-tests/Test/Ouroboros/Network/Socket.hs | 31 +- .../ouroboros-network-framework.cabal | 24 +- .../Test/Ouroboros/Network/Socket.hs | 84 ++- .../src/Ouroboros/Network/ErrorPolicy.hs | 328 --------- .../Ouroboros/Network/Protocol/Handshake.hs | 3 + .../src/Ouroboros/Network/Server/Socket.hs | 310 -------- .../src/Ouroboros/Network/Socket.hs | 487 +------------ .../src/Ouroboros/Network/Subscription.hs | 28 - .../Ouroboros/Network/Subscription/Client.hs | 76 -- .../src/Ouroboros/Network/Subscription/Dns.hs | 324 --------- .../src/Ouroboros/Network/Subscription/Ip.hs | 233 ------ .../Network/Subscription/PeerState.hs | 599 ---------------- .../Network/Subscription/Subscriber.hs | 21 - .../Ouroboros/Network/Subscription/Worker.hs | 670 ------------------ .../testlib/Test/Ouroboros/Network/Server.hs | 96 +++ 18 files changed, 190 insertions(+), 3187 deletions(-) delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs delete mode 100644 ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs create mode 100644 ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 272e1af0d77..f86e39f60f3 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -5,6 +5,16 @@ ### Breaking changes * Add `miniProtocolStart` to `MiniProtocol` to control starting strategy. +* `Ouroboros.Network.Subscription` removed. +* `Ouroboros.Network.ErrorPolicy` removed. +* APIs removed from `Ouroboros.Network.Socket`: + * `NetworkMutableState` & friends, + * `withServerNode`, + * `NetworkServerTracers`, + * `fromSnocket`, + * `beginConnection` +* `Ouroboros.Network.Server.Socket` replaced with a simpler server + implementation in `Test.Ouroboros.Network.Server` (in `ouroboros-network:testlib` component). ### Non-breaking changes diff --git a/ouroboros-network-framework/demo/ping-pong.hs b/ouroboros-network-framework/demo/ping-pong.hs index fbb6b2234fb..73ec28bc39f 100644 --- a/ouroboros-network-framework/demo/ping-pong.hs +++ b/ouroboros-network-framework/demo/ping-pong.hs @@ -27,7 +27,6 @@ import Text.Printf (printf) import Network.Mux qualified as Mx -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.Snocket @@ -35,9 +34,11 @@ import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version +import Test.Ouroboros.Network.Server qualified as Test.Server import Network.TypedProtocol.PingPong.Client as PingPong import Network.TypedProtocol.PingPong.Codec.CBOR as PingPong @@ -157,24 +158,21 @@ clientPingPong pipelined = serverPingPong :: IO Void serverPingPong = withIOManager $ \iomgr -> do - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (Snocket.localSnocket iomgr) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) defaultLocalSocketAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (unversionedProtocol (SomeResponderApplication app)) - nullErrorPolicies - $ \_ serverAsync -> - wait serverAsync -- block until async exception + $ \_ serverAsync -> wait serverAsync -- block until server finishes where app :: OuroborosApplicationWithMinimalCtx Mx.ResponderMode LocalAddress LBS.ByteString IO Void () @@ -254,24 +252,21 @@ clientPingPong2 = serverPingPong2 :: IO Void serverPingPong2 = withIOManager $ \iomgr -> do - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (Snocket.localSnocket iomgr) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) defaultLocalSocketAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (unversionedProtocol (SomeResponderApplication app)) - nullErrorPolicies - $ \_ serverAsync -> - wait serverAsync -- block until async exception + $ \_ serverAsync -> wait serverAsync -- block until async exception where app :: OuroborosApplicationWithMinimalCtx Mx.ResponderMode addr LBS.ByteString IO Void () diff --git a/ouroboros-network-framework/io-tests/Main.hs b/ouroboros-network-framework/io-tests/Main.hs index ec1f3f658ad..aa53420f74e 100644 --- a/ouroboros-network-framework/io-tests/Main.hs +++ b/ouroboros-network-framework/io-tests/Main.hs @@ -7,18 +7,16 @@ import Test.Ouroboros.Network.Driver qualified as Driver import Test.Ouroboros.Network.RawBearer qualified as RawBearer import Test.Ouroboros.Network.Server2.IO qualified as Server2 import Test.Ouroboros.Network.Socket qualified as Socket -import Test.Ouroboros.Network.Subscription qualified as Subscription main :: IO () main = withUtf8 $ defaultMain tests tests :: TestTree tests = - testGroup "ouroboros-network-framework:io-tests" $ + testGroup "ouroboros-network-framework:io-tests" [ Driver.tests , Server2.tests , Socket.tests - , Subscription.tests , RawBearer.tests ] 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 dc3bad55e9e..f70bd60ab7a 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -49,7 +49,6 @@ import Network.TypedProtocol.ReqResp.Type qualified as ReqResp import Ouroboros.Network.Context import Ouroboros.Network.Driver -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager import Ouroboros.Network.Snocket import Ouroboros.Network.Socket @@ -61,11 +60,13 @@ import Network.Mux.Bearer qualified as Mx import Network.Mux.Timeout qualified as Mx import Network.Mux.Types qualified as Mx +import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version import Test.Ouroboros.Network.Orphans () +import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (DependencyType (..), TestTree, after, testGroup) @@ -197,7 +198,6 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = cv <- newEmptyTMVarIO sv <- newEmptyTMVarIO - networkState <- newNetworkMutableState {- The siblingVar is used by the initiator and responder to wait on each other before exiting. - Without this wait there is a risk that one side will finish first causing the Muxbearer to @@ -239,20 +239,21 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = let snocket = socketSnocket iomgr res <- - withServerNode + Test.Server.with snocket Mx.makeSocketBearer ((. Just) <$> configureSock) - networkTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + + } (unversionedProtocol (SomeResponderApplication responderApp)) - nullErrorPolicies $ \_ _ -> do void $ connectToNode snocket @@ -273,14 +274,6 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = return (res == mapAccumL f 0 xs) where - networkTracers = NetworkServerTracers { - nstMuxTracer = activeMuxTracer, - nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = showTracing stdoutTracer, - nstAcceptPolicyTracer = nullTracer - } - - waitSibling :: StrictTVar IO Int -> IO () waitSibling cntVar = do atomically $ modifyTVar cntVar (\a -> a - 1) diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 0fc7c089180..71870d9011c 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -39,7 +39,6 @@ library Ouroboros.Network.Driver.Limits Ouroboros.Network.Driver.Simple Ouroboros.Network.Driver.Stateful - Ouroboros.Network.ErrorPolicy Ouroboros.Network.IOManager Ouroboros.Network.InboundGovernor Ouroboros.Network.InboundGovernor.Event @@ -57,37 +56,24 @@ library Ouroboros.Network.RethrowPolicy Ouroboros.Network.Server.ConnectionTable Ouroboros.Network.Server.RateLimiting - Ouroboros.Network.Server.Socket Ouroboros.Network.Server2 Ouroboros.Network.Snocket Ouroboros.Network.Socket - Ouroboros.Network.Subscription - Ouroboros.Network.Subscription.Client - Ouroboros.Network.Subscription.Dns - Ouroboros.Network.Subscription.Ip - Ouroboros.Network.Subscription.PeerState - Ouroboros.Network.Subscription.Subscriber - Ouroboros.Network.Subscription.Worker Simulation.Network.Snocket -- other-extensions: build-depends: -- ^ only to derive nothunk instances Win32-network ^>=0.2, - async >=2.1 && <2.3, base >=4.12 && <4.21, bytestring >=0.10 && <0.13, - cardano-prelude, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer, deepseq, - dns <4.3, hashable, io-classes ^>=1.5.0, - iproute >=1.7 && <1.8, monoidal-synchronisation ^>=0.1.0.6, - mtl, network ^>=3.2.7, network-mux ^>=0.6, nothunks, @@ -98,7 +84,6 @@ library quiet, random, si-timers, - stm, strict-stm, text, typed-protocols ^>=0.3, @@ -131,6 +116,7 @@ library testlib Test.Ouroboros.Network.InboundGovernor.Utils Test.Ouroboros.Network.Orphans Test.Ouroboros.Network.RawBearer.Utils + Test.Ouroboros.Network.Server other-modules: build-depends: @@ -178,7 +164,6 @@ test-suite sim-tests Test.Ouroboros.Network.RawBearer Test.Ouroboros.Network.Server2.Sim Test.Ouroboros.Network.Socket - Test.Ouroboros.Network.Subscription Test.Simulation.Network.Snocket build-depends: @@ -189,10 +174,8 @@ test-suite sim-tests containers, contra-tracer, directory, - dns, io-classes, io-sim, - iproute, monoidal-synchronisation, network, network-mux, @@ -250,19 +233,15 @@ test-suite io-tests Test.Ouroboros.Network.RawBearer Test.Ouroboros.Network.Server2.IO Test.Ouroboros.Network.Socket - Test.Ouroboros.Network.Subscription build-depends: QuickCheck, base >=4.14 && <4.21, bytestring, - containers, contra-tracer, directory, - dns, io-classes, io-sim, - iproute, monoidal-synchronisation, network, network-mux, @@ -309,6 +288,7 @@ executable demo-ping-pong network-mux, ouroboros-network-api, ouroboros-network-framework, + ouroboros-network-framework:testlib, typed-protocols-examples, default-language: Haskell2010 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 d467e3bcbc5..4e0649a2ebf 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -50,9 +51,8 @@ import Network.TypedProtocol.ReqResp.Type qualified as ReqResp import Ouroboros.Network.Context import Ouroboros.Network.Driver -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager -import Ouroboros.Network.Snocket +import Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Socket -- TODO: remove Mx prefixes import Ouroboros.Network.Mux @@ -63,11 +63,13 @@ import Network.Mux.Timeout import Network.Mux.Types (MiniProtocolDir (..), RemoteClockModel (..)) import Network.Mux.Types qualified as Mx +import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version import Test.Ouroboros.Network.Orphans () +import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (DependencyType (..), TestTree, after, testGroup) @@ -199,7 +201,6 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = cv <- newEmptyTMVarIO sv <- newEmptyTMVarIO - networkState <- newNetworkMutableState {- The siblingVar is used by the initiator and responder to wait on each other before exiting. - Without this wait there is a risk that one side will finish first causing the Muxbearer to @@ -240,49 +241,44 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = pure ((), trailing) let snocket = socketSnocket iomgr - res <- - withServerNode - snocket - Mx.makeSocketBearer - ((. Just) <$> configureSock) - networkTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) - responderAddr - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) - (unversionedProtocol (SomeResponderApplication responderApp)) - nullErrorPolicies - $ \_ _ -> do - void $ connectToNode - snocket - Mx.makeSocketBearer - ConnectToArgs { - ctaHandshakeCodec = unversionedHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = unversionedProtocolDataCodec, - ctaConnectTracers = NetworkConnectTracers activeMuxTracer nullTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - (`configureSock` Nothing) - (unversionedProtocol initiatorApp) - (Just initiatorAddr) - responderAddr - atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv - - return (res == mapAccumL f 0 xs) + bracket (open snocket (Snocket.addrFamily snocket responderAddr)) + (close snocket) $ \sock -> do + bind snocket sock responderAddr + listen snocket sock + res <- + Test.Server.with + snocket + makeSocketBearer + (\fd addr -> configureSock fd (Just addr)) + responderAddr + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } + (unversionedProtocol (SomeResponderApplication responderApp)) + $ \_ _ -> do + void $ connectToNode + snocket + Mx.makeSocketBearer + ConnectToArgs { + ctaHandshakeCodec = unversionedHandshakeCodec, + ctaHandshakeTimeLimits = noTimeLimitsHandshake, + ctaVersionDataCodec = unversionedProtocolDataCodec, + ctaConnectTracers = NetworkConnectTracers activeMuxTracer nullTracer, + ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion + } + (`configureSock` Nothing) + (unversionedProtocol initiatorApp) + (Just initiatorAddr) + responderAddr + atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv + return (res == mapAccumL f 0 xs) where - networkTracers = NetworkServerTracers { - nstMuxTracer = activeMuxTracer, - nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = showTracing stdoutTracer, - nstAcceptPolicyTracer = nullTracer - } - - waitSibling :: StrictTVar IO Int -> IO () waitSibling cntVar = do atomically $ modifyTVar cntVar (\a -> a - 1) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs b/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs deleted file mode 100644 index 518f243208c..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Error policies, and integration with 'SuspendDecision'-semigroup action on --- 'PeerState'. --- -module Ouroboros.Network.ErrorPolicy - ( ErrorPolicies (..) - , nullErrorPolicies - , ErrorPolicy (..) - , evalErrorPolicy - , evalErrorPolicies - , CompleteApplication - , CompleteApplicationResult (..) - , Result (..) - , completeApplicationTx - -- * Traces - , ErrorPolicyTrace (..) - , traceErrorPolicy - , WithAddr (..) - -- * Re-exports of PeerState - , PeerStates - , SuspendDecision (..) - ) where - -import Control.Exception (Exception, IOException, SomeException (..)) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) -import Data.Semigroup (sconcat) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Typeable (Proxy (..), cast, tyConName, typeRep, typeRepTyCon) -import Text.Printf - -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime.SI - -import Ouroboros.Network.Subscription.PeerState - -data ErrorPolicy where - ErrorPolicy :: forall e. - Exception e - => (e -> Maybe (SuspendDecision DiffTime)) - -- ^ @Nothing@ means no decision. It is equivalent to not - -- having the policy at all. In 'evalErrorPolicies' this will - -- fall-through and match against the remaining policies. - -> ErrorPolicy - -instance Show ErrorPolicy where - show (ErrorPolicy (_err :: e -> Maybe (SuspendDecision DiffTime))) = - "ErrorPolicy (" - ++ tyConName (typeRepTyCon (typeRep (Proxy :: Proxy e))) - ++ ")" - - -evalErrorPolicy :: forall e. - Exception e - => e - -> ErrorPolicy - -> Maybe (SuspendDecision DiffTime) -evalErrorPolicy e p = - case p of - ErrorPolicy (f :: e' -> Maybe (SuspendDecision DiffTime)) - -> case cast e :: Maybe e' of - Nothing -> Nothing - Just e' -> f e' - --- | Evaluate a list of 'ErrorPolicy's; If none of them applies this function --- returns 'Nothing', in this case the exception will be traced and not thrown. --- -evalErrorPolicies :: forall e. - Exception e - => e - -> [ErrorPolicy] - -> Maybe (SuspendDecision DiffTime) -evalErrorPolicies e = - f . mapMaybe (evalErrorPolicy e) - where - f :: [SuspendDecision DiffTime] - -> Maybe (SuspendDecision DiffTime) - f [] = Nothing - f (cmd : rst) = Just $ sconcat (cmd :| rst) - - --- | List of error policies for exception handling and a policy for handing --- application return values. --- -data ErrorPolicies = ErrorPolicies { - -- | Application Error Policies - epAppErrorPolicies :: [ErrorPolicy] - -- | `connect` Error Policies - , epConErrorPolicies :: [ErrorPolicy] - } - -nullErrorPolicies :: ErrorPolicies -nullErrorPolicies = ErrorPolicies [] [] - -instance Semigroup ErrorPolicies where - ErrorPolicies aep cep <> ErrorPolicies aep' cep' - = ErrorPolicies (aep <> aep') (cep <> cep') - --- | Sum type which distinguishes between connection and application --- exception traces. --- -data ConnectionOrApplicationExceptionTrace err = - -- | Trace of exception thrown by `connect` - ConnectionExceptionTrace err - -- | Trace of exception thrown by an application - | ApplicationExceptionTrace err - deriving (Show, Functor) - - --- | Complete a connection, which receive application result (or exception). --- -type CompleteApplication m s addr r = - Result addr r -> s -> STM m (CompleteApplicationResult m addr s) - - --- | Result of the connection thread. It's either result of an application, or --- an exception thrown by it. --- -data Result addr r where - ApplicationResult - :: !Time - -> !addr - -> !r - -> Result addr r - - Connected - :: !Time - -> !addr - -> Result addr r - - ConnectionError - :: Exception e - => !Time - -> !addr - -> !e - -> Result addr r - - ApplicationError - :: Exception e - => !Time - -> !addr - -> !e - -> Result addr r - - -data CompleteApplicationResult m addr s = - CompleteApplicationResult { - carState :: !s, - -- ^ new state - carThreads :: Set (Async m ()), - -- ^ threads to kill - carTrace :: Maybe (WithAddr addr ErrorPolicyTrace) - -- ^ trace points - } - deriving Functor - - --- | 'CompleteApplication' callback --- -completeApplicationTx - :: forall m addr a. - ( MonadAsync m - , Ord addr - , Ord (Async m ()) - ) - => ErrorPolicies - -> CompleteApplication m - (PeerStates m addr) - addr - a - --- the 'ResultQ' did not throw the exception yet; it should not happen. -completeApplicationTx _ _ ps@ThrowException{} = pure $ - CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Nothing - } - --- application returned; classify the return value and update the state. -completeApplicationTx _ ApplicationResult{} ps = - pure $ CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Nothing - } - --- application errored -completeApplicationTx ErrorPolicies {epAppErrorPolicies} (ApplicationError t addr e) ps = - case evalErrorPolicies e epAppErrorPolicies of - -- the error is not handled by any policy; we're not rethrowing the - -- error from the main thread, we only trace it. This will only kill - -- the local consumer application. - Nothing -> pure $ - CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Just - (WithAddr addr - (ErrorPolicyUnhandledApplicationException - (SomeException e))) - } - -- the error was classified; act with the 'SuspendDecision' on the state - -- and find threads to cancel. - Just cmd -> case runSuspendDecision t addr e cmd ps of - (ps', threads) -> - pure $ - CompleteApplicationResult { - carState = ps', - carThreads = threads, - carTrace = WithAddr addr <$> - traceErrorPolicy - (Left $ ApplicationExceptionTrace (SomeException e)) - cmd - } - --- we connected to a peer; this does not require to update the 'PeerState'. -completeApplicationTx _ (Connected _t _addr) ps = - pure $ - CompleteApplicationResult { - carState = ps, - carThreads = Set.empty, - carTrace = Nothing - } - --- error raised by the 'connect' call -completeApplicationTx ErrorPolicies {epConErrorPolicies} (ConnectionError t addr e) ps = - case evalErrorPolicies e epConErrorPolicies of - Nothing -> - let fn p@(HotPeer producers consumers) - | Set.null producers && Set.null consumers - = Just ColdPeer - | otherwise - = Just p - fn p = Just p - - in pure $ - CompleteApplicationResult { - carState = - case ps of - PeerStates peerStates -> PeerStates $ Map.update fn addr peerStates -#if __GLASGOW_HASKELL__ < 900 - -- GHC 9 is certain this pattern is - -- not used. GHC 8 apparently can't - -- agree. m( - ThrowException{} -> ps -#endif - , carThreads = Set.empty - , carTrace = Just $ - WithAddr addr - (ErrorPolicyUnhandledConnectionException - (SomeException e)) - } - Just cmd -> case runSuspendDecision t addr e cmd ps of - (ps', threads) -> - pure $ - CompleteApplicationResult { - carState = ps', - carThreads = threads, - carTrace = WithAddr addr <$> - (traceErrorPolicy - (Left $ ConnectionExceptionTrace (SomeException e)) - cmd) - } - --- --- Traces --- - --- | Trace data for error policies -data ErrorPolicyTrace - = ErrorPolicySuspendPeer (Maybe (ConnectionOrApplicationExceptionTrace SomeException)) DiffTime DiffTime - -- ^ suspending peer with a given exception until - | ErrorPolicySuspendConsumer (Maybe (ConnectionOrApplicationExceptionTrace SomeException)) DiffTime - -- ^ suspending consumer until - | ErrorPolicyLocalNodeError (ConnectionOrApplicationExceptionTrace SomeException) - -- ^ caught a local exception - | ErrorPolicyResumePeer - -- ^ resume a peer (both consumer and producer) - | ErrorPolicyKeepSuspended - -- ^ consumer was suspended until producer will resume - | ErrorPolicyResumeConsumer - -- ^ resume consumer - | ErrorPolicyResumeProducer - -- ^ resume producer - | ErrorPolicyUnhandledApplicationException SomeException - -- ^ an application throwed an exception, which was not handled by any - -- 'ErrorPolicy'. - | ErrorPolicyUnhandledConnectionException SomeException - -- ^ 'connect' throwed an exception, which was not handled by any - -- 'ErrorPolicy'. - | ErrorPolicyAcceptException IOException - -- ^ 'accept' throwed an exception - deriving Show - -traceErrorPolicy :: Either (ConnectionOrApplicationExceptionTrace SomeException) r - -> SuspendDecision DiffTime - -> Maybe ErrorPolicyTrace -traceErrorPolicy (Left e) (SuspendPeer prodT consT) = - Just $ ErrorPolicySuspendPeer (Just e) prodT consT -traceErrorPolicy (Right _) (SuspendPeer prodT consT) = - Just $ ErrorPolicySuspendPeer Nothing prodT consT -traceErrorPolicy (Left e) (SuspendConsumer consT) = - Just $ ErrorPolicySuspendConsumer (Just e) consT -traceErrorPolicy (Right _) (SuspendConsumer consT) = - Just $ ErrorPolicySuspendConsumer Nothing consT -traceErrorPolicy (Left e) Throw = - Just $ ErrorPolicyLocalNodeError e -traceErrorPolicy _ _ = - Nothing - -data WithAddr addr a = WithAddr { - wiaAddr :: addr - , wiaEvent :: a - } - -instance (Show addr, Show a) => Show (WithAddr addr a) where - show WithAddr { wiaAddr, wiaEvent } = - printf "IP %s %s" (show wiaAddr) (show wiaEvent) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs index 70997136aa4..c9e25dbda46 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs @@ -48,6 +48,9 @@ handshakeProtocolNum = Mx.MiniProtocolNum 0 -- | Wrapper around initiator and responder errors experienced by tryHandshake. -- +-- TODO: should we have `Exception` instance? +-- It would be handly in `prop_socket_send_recgtv`. +-- data HandshakeException vNumber = HandshakeProtocolLimit ProtocolLimitFailure | HandshakeProtocolError (HandshakeProtocolError vNumber) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs deleted file mode 100644 index 06ec7f03629..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - --- `accept` is shadowed, but so what? -{-# OPTIONS_GHC "-fno-warn-name-shadowing" #-} - -module Ouroboros.Network.Server.Socket - ( AcceptedConnectionsLimit (..) - , AcceptConnectionsPolicyTrace (..) - , BeginConnection - , HandleConnection (..) - , ApplicationStart - , CompleteConnection - , CompleteApplicationResult (..) - , Result (..) - , Main - , run - , Socket (..) - , ioSocket - ) where - -import Control.Concurrent.Async (Async) -import Control.Concurrent.Async qualified as Async -import Control.Concurrent.STM (STM) -import Control.Concurrent.STM qualified as STM -import Control.Exception (IOException, SomeException (..), finally, mask, mask_, - onException, try) -import Control.Monad (forM_, join) -import Control.Monad.Class.MonadTime.SI (Time, getMonotonicTime) -import Control.Monad.Class.MonadTimer.SI (threadDelay) -import Control.Tracer (Tracer, traceWith) -import Data.Foldable (traverse_) -import Data.Set (Set) -import Data.Set qualified as Set - -import Ouroboros.Network.ErrorPolicy (CompleteApplicationResult (..), - ErrorPolicyTrace, WithAddr) -import Ouroboros.Network.Server.RateLimiting - --- | Abstraction of something that can provide connections. --- A `Network.Socket` can be used to get a --- `Socket SockAddr (Channel IO Lazy.ByteString)` --- It's not defined in here, though, because we don't want the dependency --- on typed-protocols or even on network. -data Socket addr channel = Socket - { acceptConnection :: IO (addr, channel, IO (), Socket addr channel) - -- ^ The address, a channel, IO to close the channel. - } - --- | Expected to be useful for testing. -ioSocket :: IO (addr, channel) -> Socket addr channel -ioSocket io = Socket - { acceptConnection = do - (addr, channel) <- io - pure (addr, channel, pure (), ioSocket io) - } - -type StatusVar st = STM.TVar st - - --- | What to do with a new connection: reject it and give a new state, or --- accept it and give a new state with a continuation to run against the --- resulting channel. --- See also `CompleteConnection`, which is run for every connection when it finishes, and --- can also update the state. -data HandleConnection channel st r where - Reject :: !st -> HandleConnection channel st r - Accept :: !st -> !(channel -> IO r) -> HandleConnection channel st r - --- | What to do on a new connection: accept and run this `IO`, or reject. -type BeginConnection addr channel st r = Time -> addr -> st -> STM (HandleConnection channel st r) - --- | A call back which runs when application starts; --- --- It is needed only because 'BeginConnection' does not have access to the --- thread which runs the application. --- -type ApplicationStart addr st = addr -> Async () -> st -> STM st - --- | How to update state when a connection finishes. Can use `throwSTM` to --- terminate the server. --- --- TODO: remove 'async', use `Async m ()` from 'MonadAsync'. -type CompleteConnection addr st tr r = - Result addr r -> st -> STM (CompleteApplicationResult IO addr st) - --- | Given a current state, `retry` unless you want to stop the server. --- When this transaction returns, any running threads spawned by the server --- will be killed. --- --- It's possible that a connection is accepted after the main thread --- returns, but before the server stops. In that case, it will be killed, and --- the `CompleteConnection` will not run against it. -type Main st t = st -> STM t - --- | To avoid repeatedly blocking on the set of all running threads (a --- potentially very large STM transaction) the results come in by way of a --- `TQueue`. Using a queue rather than, say, a `TMVar`, also finesses a --- potential deadlock when shutting down the server and killing spawned threads: --- the server can stop pulling from the queue, without causing the child --- threads to hang attempting to write to it. -type ResultQ addr r = STM.TQueue (Result addr r) - --- | The product of a spawned thread. We catch all (even async) exceptions. -data Result addr r = Result - { resultThread :: !(Async ()) - , resultAddr :: !addr - , resultTime :: !Time - , resultValue :: !(Either SomeException r) - } - --- | The set of all spawned threads. Used for waiting or cancelling them when --- the server shuts down. -type ThreadsVar = STM.TVar (Set (Async ())) - - --- | The action runs inside `try`, and when it finishes, puts its result --- into the `ResultQ`. Takes care of inserting/deleting from the `ThreadsVar`. --- --- Async exceptions are masked to ensure that if the thread is spawned, it --- always gets into the `ThreadsVar`. Exceptions are unmasked in the --- spawned thread. -spawnOne - :: addr - -> StatusVar st - -> ResultQ addr r - -> ThreadsVar - -> ApplicationStart addr st - -> IO r - -> IO () -spawnOne remoteAddr statusVar resQ threadsVar applicationStart io = mask_ $ do - rec let threadAction = \unmask -> do - STM.atomically $ - STM.readTVar statusVar - >>= applicationStart remoteAddr thread - >>= (STM.writeTVar statusVar $!) - val <- try (unmask io) - t <- getMonotonicTime - -- No matter what the exception, async or sync, this will not - -- deadlock, since we use a `TQueue`. If the server kills its - -- children, and stops clearing the queue, it will be collected - -- shortly thereafter, so no problem. - STM.atomically $ STM.writeTQueue resQ (Result thread remoteAddr t val) - thread <- Async.asyncWithUnmask $ \unmask -> - threadAction unmask - -- The main loop `connectionTx` will remove this entry from the set, once - -- it receives the result. - STM.atomically $ STM.modifyTVar' threadsVar (Set.insert thread) - - --- | The accept thread is controlled entirely by the `accept` call. To --- stop it, whether normally or exceptionally, it must be killed by an async --- exception, or the exception callback here must re-throw. -acceptLoop - :: Tracer IO AcceptConnectionsPolicyTrace - -> ResultQ addr r - -> ThreadsVar - -> StatusVar st - -> AcceptedConnectionsLimit - -> BeginConnection addr channel st r - -> ApplicationStart addr st - -> (IOException -> IO ()) -- ^ Exception on `Socket.accept`. - -> Socket addr channel - -> IO () -acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket = do - mNextSocket <- acceptOne acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - case mNextSocket of - Nothing -> do - -- Thread delay to mitigate potential livelock. - threadDelay 0.5 - acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - Just nextSocket -> - acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException nextSocket - --- | Accept once from the socket, use the `Accept` to make a decision (accept --- or reject), and spawn the thread if accepted. -acceptOne - :: forall addr channel st r. - Tracer IO AcceptConnectionsPolicyTrace - -> ResultQ addr r - -> ThreadsVar - -> StatusVar st - -> AcceptedConnectionsLimit - -> BeginConnection addr channel st r - -> ApplicationStart addr st - -> (IOException -> IO ()) -- ^ Exception on `Socket.accept`. - -> Socket addr channel - -> IO (Maybe (Socket addr channel)) -acceptOne acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionsLimit beginConnection applicationStart acceptException socket = mask $ \restore -> do - - -- Rate limiting of accepted connections; this might block. - runConnectionRateLimits - acceptPolicyTrace - (Set.size <$> STM.readTVar threadsVar) - acceptedConnectionsLimit - - -- mask is to assure that every socket is closed. - outcome <- try (restore (acceptConnection socket)) - case outcome :: Either IOException (addr, channel, IO (), Socket addr channel) of - Left ex -> do - -- Classify the exception, if it is fatal to the node or not. - -- If it is fatal to the node the exception will propagate. - restore (acceptException ex) - pure Nothing - Right (addr, channel, close, nextSocket) -> do - -- Decide whether to accept or reject, using the current state, and - -- update it according to the decision. - t <- getMonotonicTime - let decision = STM.atomically $ do - st <- STM.readTVar statusVar - !handleConn <- beginConnection t addr st - case handleConn of - Reject st' -> do - STM.writeTVar statusVar st' - pure Nothing - Accept st' io -> do - STM.writeTVar statusVar st' - pure $ Just io - -- this could be interrupted, so we use `onException` to close the - -- socket. - choice <- decision `onException` close - case choice of - Nothing -> close - Just io -> spawnOne addr statusVar resQ threadsVar applicationStart (io channel `finally` close) - pure (Just nextSocket) - --- | Main server loop, which runs alongside the `acceptLoop`. It waits for --- the results of connection threads, as well as the `Main` action, which --- determines when/if the server should stop. -mainLoop - :: forall addr st tr r t . - Tracer IO (WithAddr addr ErrorPolicyTrace) - -> ResultQ addr r - -> ThreadsVar - -> StatusVar st - -> CompleteConnection addr st tr r - -> Main st t - -> IO t -mainLoop errorPolicyTrace resQ threadsVar statusVar complete main = - join (STM.atomically $ mainTx `STM.orElse` connectionTx) - - where - - -- Sample the status, and run the main action. If it does not retry, then - -- the `mainLoop` finishes with `pure t` where `t` is the main action result. - mainTx :: STM (IO t) - mainTx = do - st <- STM.readTVar statusVar - t <- main st - pure $ pure t - - -- Wait for some connection to finish, update the state with its result, - -- then recurse onto `mainLoop`. - connectionTx :: STM (IO t) - connectionTx = do - result <- STM.readTQueue resQ - -- Make sure we don't cleanup before spawnOne has inserted the thread - isMember <- Set.member (resultThread result) <$> STM.readTVar threadsVar - STM.check isMember - - st <- STM.readTVar statusVar - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- complete result st - -- 'CompleteConnectionResult' is strict in 'ccrState', thus we write - -- evaluted state to 'statusVar' - STM.writeTVar statusVar carState - -- It was inserted by `spawnOne`. - STM.modifyTVar' threadsVar (Set.delete (resultThread result)) - pure $ do - traverse_ Async.cancel carThreads - traverse_ (traceWith errorPolicyTrace) carTrace - mainLoop errorPolicyTrace resQ threadsVar statusVar complete main - - --- | Run a server. -run - :: Tracer IO (WithAddr addr ErrorPolicyTrace) - -> Tracer IO AcceptConnectionsPolicyTrace - -- TODO: extend this trace to trace server action (this might be useful for - -- debugging) - -> Socket addr channel - -> AcceptedConnectionsLimit - -> (IOException -> IO ()) - -> BeginConnection addr channel st r - -> ApplicationStart addr st - -> CompleteConnection addr st tr r - -> Main st t - -> STM.TVar st - -> IO t -run errroPolicyTrace acceptPolicyTrace socket acceptedConnectionLimit acceptException beginConnection applicationStart complete main statusVar = do - resQ <- STM.newTQueueIO - threadsVar <- STM.newTVarIO Set.empty - let acceptLoopDo = acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - -- The accept loop is killed when the main loop stops and the main - -- loop is killed if the accept loop stops. - mainDo = mainLoop errroPolicyTrace resQ threadsVar statusVar complete main - killChildren = do - children <- STM.atomically $ STM.readTVar threadsVar - forM_ (Set.toList children) Async.cancel - -- After both the main and accept loop have been killed, any remaining - -- spawned threads are cancelled. - (snd <$> Async.concurrently acceptLoopDo mainDo) `finally` killChildren diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index ac33c3b6c46..8700072b4e5 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -24,15 +24,8 @@ module Ouroboros.Network.Socket ConnectionTable , ConnectionTableRef (..) , ValencyCounter - , NetworkMutableState (..) , SomeResponderApplication (..) - , newNetworkMutableState - , newNetworkMutableStateSTM - , cleanNetworkMutableState - , AcceptedConnectionsLimit (..) , ConnectionId (..) - , withServerNode - , withServerNode' , ConnectToArgs (..) , connectToNode , connectToNodeWithMux @@ -47,17 +40,8 @@ module Ouroboros.Network.Socket , NetworkConnectTracers (..) , nullNetworkConnectTracers , debuggingNetworkConnectTracers - , NetworkServerTracers (..) - , nullNetworkServerTracers - , debuggingNetworkServerTracers - , AcceptConnectionsPolicyTrace (..) - -- * Helper function for creating servers - , fromSnocket - , beginConnection -- * Re-export of HandshakeCallbacks , HandshakeCallbacks (..) - -- * Re-export of PeerStates - , PeerStates -- * Re-export connection table functions , newConnectionTable , refConnection @@ -70,33 +54,24 @@ module Ouroboros.Network.Socket , readValencyCounter -- * Auxiliary functions , sockAddrFamily + , simpleMuxCallback ) where -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Exception (SomeException (..)) -import Control.Monad.Class.MonadAsync --- TODO: remove this, it will not be needed when `orElse` PR will be merged. import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (unless, when) +import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.STM qualified as STM import Data.Bifunctor (first) import Data.ByteString.Lazy qualified as BL import Data.Foldable (traverse_) -import Data.Functor (void) import Data.Hashable import Data.Monoid.Synchronisation (FirstToFinish (..)) import Data.Typeable (Typeable) -import Data.Void import Data.Word (Word16) -import GHC.IO.Exception -#if !defined(mingw32_HOST_OS) -import Foreign.C.Error -#endif import Network.Socket (SockAddr, Socket, StructLinger (..)) import Network.Socket qualified as Socket @@ -110,7 +85,6 @@ import Network.TypedProtocol.Codec hiding (decode, encode) import Ouroboros.Network.Context import Ouroboros.Network.Driver.Limits -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.Handshake (HandshakeCallbacks (..)) import Ouroboros.Network.IOManager (IOManager) import Ouroboros.Network.Mux @@ -118,12 +92,8 @@ import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Server.ConnectionTable -import Ouroboros.Network.Server.Socket (AcceptConnectionsPolicyTrace (..), - AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server.Socket qualified as Server import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Subscription.PeerState -- | Tracer used by 'connectToNode' (and derivatives, like @@ -530,452 +500,3 @@ data SomeResponderApplication addr bytes m b where Mx.HasResponder muxMode ~ True => (OuroborosApplicationWithMinimalCtx muxMode addr bytes m a b) -> SomeResponderApplication addr bytes m b - --- | --- Accept or reject an incoming connection. Each record contains the new state --- after accepting / rejecting a connection. When accepting a connection one --- has to give a mux application which necessarily has the server side, and --- optionally has the client side. --- --- TODO: --- If the other side will not allow us to run the client side on the incoming --- connection, the whole connection will terminate. We might want to be more --- admissible in this scenario: leave the server thread running and let only --- the client thread to die. -data AcceptConnection st vNumber vData peerid m bytes where - - AcceptConnection - :: forall st vNumber vData peerid bytes m b. - !st - -> !(ConnectionId peerid) - -> Versions vNumber vData (SomeResponderApplication peerid bytes m b) - -> AcceptConnection st vNumber vData peerid m bytes - - RejectConnection - :: !st - -> !(ConnectionId peerid) - -> AcceptConnection st vNumber vData peerid m bytes - - --- | Accept or reject incoming connection based on the current state and --- address of the incoming connection. --- -beginConnection - :: forall vNumber vData addr st fd. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - ) - => Mx.MakeBearer IO fd - -> Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace) - -> Tracer IO (Mx.WithBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))) - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> (Time -> addr -> st -> STM.STM (AcceptConnection st vNumber vData addr IO BL.ByteString)) - -- ^ either accept or reject a connection. - -> Server.BeginConnection addr fd st () -beginConnection makeBearer muxTracer handshakeTracer handshakeCodec handshakeTimeLimits versionDataCodec handshakeCallbacks fn t addr st = do - accept <- fn t addr st - case accept of - AcceptConnection st' connectionId versions -> pure $ Server.Accept st' $ \sd -> do - muxTracer' <- initDeltaQTracer' $ Mx.WithBearer connectionId `contramap` muxTracer - - traceWith muxTracer' $ Mx.TraceHandshakeStart - - handshakeBearer <- Mx.getBearer makeBearer sduHandshakeTimeout muxTracer' sd - app_e <- - runHandshakeServer - handshakeBearer - connectionId - HandshakeArguments { - haHandshakeTracer = handshakeTracer, - haHandshakeCodec = handshakeCodec, - haVersionDataCodec = versionDataCodec, - haAcceptVersion = acceptCb handshakeCallbacks, - haQueryVersion = queryCb handshakeCallbacks, - haTimeLimits = handshakeTimeLimits - } - versions - - case app_e of - Left (HandshakeProtocolLimit err) -> do - traceWith muxTracer' $ Mx.TraceHandshakeServerError err - throwIO err - - Left (HandshakeProtocolError err) -> do - traceWith muxTracer' $ Mx.TraceHandshakeServerError err - throwIO err - - Right (HandshakeNegotiationResult (SomeResponderApplication app) versionNumber agreedOptions) -> do - traceWith muxTracer' Mx.TraceHandshakeServerEnd - bearer <- Mx.getBearer makeBearer sduTimeout muxTracer' sd - -- non-p2p: use `noBindForkPolicy` - mux <- Mx.new (toMiniProtocolInfos (runForkPolicy noBindForkPolicy remoteAddress) app) - withAsync (Mx.run muxTracer' mux bearer) $ \aid -> - void $ simpleMuxCallback connectionId versionNumber agreedOptions app mux aid - - Right (HandshakeQueryResult _vMap) -> do - traceWith muxTracer' Mx.TraceHandshakeServerEnd - -- Wait 20s for client to receive response, who should close the connection. - threadDelay handshake_QUERY_SHUTDOWN_DELAY - - RejectConnection st' _peerid -> pure $ Server.Reject st' - - -mkListeningSocket - :: Snocket IO fd addr - -> (fd -> addr -> IO ()) - -> addr - -> Snocket.AddressFamily addr - -> IO fd -mkListeningSocket sn configureSock addr family_ = do - sd <- Snocket.open sn family_ - configureSock sd addr - Snocket.bind sn sd addr - Snocket.listen sn sd - pure sd - --- | --- Make a server-compatible socket from a network socket. --- -fromSnocket - :: forall fd addr. Ord addr - => ConnectionTable IO addr - -> Snocket IO fd addr - -> fd -- ^ socket or handle - -> IO (Server.Socket addr fd) -fromSnocket tblVar sn sd = go <$> Snocket.accept sn sd - where - go :: Snocket.Accept IO fd addr -> Server.Socket addr fd - go (Snocket.Accept accept) = Server.Socket $ do - (result, next) <- accept - case result of - Snocket.Accepted sd' remoteAddr -> do - -- TOOD: we don't need to that on each accept - localAddr <- Snocket.getLocalAddr sn sd' - atomically $ addConnection tblVar remoteAddr localAddr ConnectionInbound Nothing - pure (remoteAddr, sd', close remoteAddr localAddr sd', go next) - Snocket.AcceptFailure err -> - -- the is no way to construct 'Server.Socket'; This will be removed in a later commit! - throwIO err - - close remoteAddr localAddr sd' = do - removeConnection tblVar remoteAddr localAddr ConnectionInbound - Snocket.close sn sd' - - --- | Tracers required by a server which handles inbound connections. --- -data NetworkServerTracers addr vNumber = NetworkServerTracers { - nstMuxTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace), - -- ^ low level mux-network tracer, which logs mux sdu (send and received) - -- and other low level multiplexing events. - nstHandshakeTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) - (TraceSendRecv (Handshake vNumber CBOR.Term))), - -- ^ handshake protocol tracer; it is important for analysing version - -- negotation mismatches. - nstErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), - -- ^ error policy tracer; must not be 'nullTracer', otherwise all the - -- exceptions which are not matched by any error policy will be caught - -- and not logged or rethrown. - nstAcceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace - -- ^ tracing rate limiting of accepting connections. - } - -nullNetworkServerTracers :: NetworkServerTracers addr vNumber -nullNetworkServerTracers = NetworkServerTracers { - nstMuxTracer = nullTracer, - nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = nullTracer, - nstAcceptPolicyTracer = nullTracer - } - -debuggingNetworkServerTracers :: (Show addr, Show vNumber) - => NetworkServerTracers addr vNumber -debuggingNetworkServerTracers = NetworkServerTracers { - nstMuxTracer = showTracing stdoutTracer, - nstHandshakeTracer = showTracing stdoutTracer, - nstErrorPolicyTracer = showTracing stdoutTracer, - nstAcceptPolicyTracer = showTracing stdoutTracer - } - - --- | Mutable state maintained by the network component. --- -data NetworkMutableState addr = NetworkMutableState { - nmsConnectionTable :: ConnectionTable IO addr, - -- ^ 'ConnectionTable' which maintains information about current upstream and - -- downstream connections. - nmsPeerStates :: StrictTVar IO (PeerStates IO addr) - -- ^ 'PeerStates' which maintains state of each downstream / upstream peer - -- that errored, misbehaved or was not interesting to us. - } - -newNetworkMutableStateSTM :: STM.STM (NetworkMutableState addr) -newNetworkMutableStateSTM = - NetworkMutableState <$> newConnectionTableSTM - <*> newPeerStatesVarSTM - -newNetworkMutableState :: IO (NetworkMutableState addr) -newNetworkMutableState = atomically newNetworkMutableStateSTM - --- | Clean 'PeerStates' within 'NetworkMutableState' every 200s --- -cleanNetworkMutableState :: NetworkMutableState addr - -> IO () -cleanNetworkMutableState NetworkMutableState {nmsPeerStates} = - cleanPeerStates 200 nmsPeerStates - --- | --- Thin wrapper around @'Server.run'@. --- -runServerThread - :: forall vNumber vData fd addr b. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - , Ord addr - ) - => NetworkServerTracers addr vNumber - -> NetworkMutableState addr - -> Snocket IO fd addr - -> Mx.MakeBearer IO fd - -> fd - -> AcceptedConnectionsLimit - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString IO b) - -> ErrorPolicies - -> IO Void -runServerThread NetworkServerTracers { nstMuxTracer - , nstHandshakeTracer - , nstErrorPolicyTracer - , nstAcceptPolicyTracer - } - NetworkMutableState { nmsConnectionTable - , nmsPeerStates } - sn - makeBearer - sd - acceptedConnectionsLimit - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies = do - sockAddr <- Snocket.getLocalAddr sn sd - serverSocket <- fromSnocket nmsConnectionTable sn sd - Server.run - nstErrorPolicyTracer - nstAcceptPolicyTracer - serverSocket - acceptedConnectionsLimit - (acceptException sockAddr) - (beginConnection makeBearer nstMuxTracer nstHandshakeTracer handshakeCodec handshakeTimeLimits versionDataCodec handshakeCallbacks (acceptConnectionTx sockAddr)) - -- register producer when application starts, it will be unregistered - -- using 'CompleteConnection' - (\remoteAddr thread st -> pure $ registerProducer remoteAddr thread - st) - completeTx mainTx (toLazyTVar nmsPeerStates) - where - mainTx :: Server.Main (PeerStates IO addr) Void - mainTx (ThrowException e) = throwIO e - mainTx PeerStates{} = retry - - -- When a connection completes, we do nothing. State is (). - -- Crucially: we don't re-throw exceptions, because doing so would - -- bring down the server. - completeTx :: Server.CompleteConnection - addr - (PeerStates IO addr) - (WithAddr addr ErrorPolicyTrace) - () - completeTx result st = case result of - - Server.Result thread remoteAddr t (Left (SomeException e)) -> - fmap (unregisterProducer remoteAddr thread) - <$> completeApplicationTx errorPolicies (ApplicationError t remoteAddr e) st - - Server.Result thread remoteAddr t (Right r) -> - fmap (unregisterProducer remoteAddr thread) - <$> completeApplicationTx errorPolicies (ApplicationResult t remoteAddr r) st - - iseCONNABORTED :: IOError -> Bool -#if defined(mingw32_HOST_OS) - -- On Windows the network packet classifies all errors - -- as OtherError. This means that we're forced to match - -- on the error string. The text string comes from - -- the network package's winSockErr.c, and if it ever - -- changes we must update our text string too. - iseCONNABORTED (IOError _ _ _ "Software caused connection abort (WSAECONNABORTED)" _ _) = True - iseCONNABORTED _ = False -#else - iseCONNABORTED (IOError _ _ _ _ (Just cerrno) _) = eCONNABORTED == Errno cerrno -#if defined(darwin_HOST_OS) - -- There is a bug in accept for IPv6 sockets. Instead of returning -1 - -- and setting errno to ECONNABORTED an invalid (>= 0) file descriptor - -- is returned, with the client address left unchanged. The uninitialized - -- client address causes the network package to throw the user error below. - iseCONNABORTED (IOError _ UserError _ "Network.Socket.Types.peekSockAddr: address family '0' not supported." _ _) = True -#endif - iseCONNABORTED _ = False -#endif - - - acceptException :: addr -> IOException -> IO () - acceptException a e = do - traceWith (WithAddr a `contramap` nstErrorPolicyTracer) $ ErrorPolicyAcceptException e - - -- Try the determine if the connection was aborted by the remote end - -- before we could process the accept, or if it was a resource exaustion - -- problem. - -- NB. This piece of code is fragile and depends on specific - -- strings/mappings in the network and base libraries. - if iseCONNABORTED e then return () - else throwIO e - - acceptConnectionTx sockAddr t connAddr st = do - d <- beforeConnectTx t connAddr st - case d of - AllowConnection st' -> pure $ AcceptConnection st' (ConnectionId sockAddr connAddr) versions - OnlyAccept st' -> pure $ AcceptConnection st' (ConnectionId sockAddr connAddr) versions - DisallowConnection st' -> pure $ RejectConnection st' (ConnectionId sockAddr connAddr) - --- | Run a server application. It will listen on the given address for incoming --- connection, otherwise like withServerNode'. -withServerNode - :: forall vNumber vData t fd addr b. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - , Ord addr - ) - => Snocket IO fd addr - -> Mx.MakeBearer IO fd - -> (fd -> addr -> IO ()) -- ^ callback to configure a socket - -> NetworkServerTracers addr vNumber - -> NetworkMutableState addr - -> AcceptedConnectionsLimit - -> addr - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString IO b) - -- ^ The mux application that will be run on each incoming connection from - -- a given address. Note that if @'MuxClientAndServerApplication'@ is - -- returned, the connection will run a full duplex set of mini-protocols. - -> ErrorPolicies - -> (addr -> Async IO Void -> IO t) - -- ^ callback which takes the @Async@ of the thread that is running the server. - -- Note: the server thread will terminate when the callback returns or - -- throws an exception. - -> IO t -withServerNode sn makeBearer - configureSock - tracers - networkState - acceptedConnectionsLimit - addr - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies - k = - bracket (mkListeningSocket sn configureSock addr (Snocket.addrFamily sn addr)) (Snocket.close sn) $ \sd -> do - withServerNode' - sn - makeBearer - tracers - networkState - acceptedConnectionsLimit - sd - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies - k - --- | --- Run a server application on the provided socket. The socket must be ready to accept connections. --- The server thread runs using @withAsync@ function, which means --- that it will terminate when the callback terminates or throws an exception. --- --- TODO: we should track connections in the state and refuse connections from --- peers we are already connected to. This is also the right place to ban --- connection from peers which misbehaved. --- --- The server will run handshake protocol on each incoming connection. We --- assume that each version negotiation message should fit into --- @'maxTransmissionUnit'@ (~5k bytes). --- --- Note: it will open a socket in the current thread and pass it to the spawned --- thread which runs the server. This makes it useful for testing, where we --- need to guarantee that a socket is open before we try to connect to it. -withServerNode' - :: forall vNumber vData t fd addr b. - ( Ord vNumber - , Typeable vNumber - , Show vNumber - , Ord addr - ) - => Snocket IO fd addr - -> Mx.MakeBearer IO fd - -> NetworkServerTracers addr vNumber - -> NetworkMutableState addr - -> AcceptedConnectionsLimit - -> fd - -- ^ a configured socket to be used be the server. The server will call - -- `bind` and `listen` methods but it will not set any socket or tcp options - -- on it. - -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString - -> ProtocolTimeLimits (Handshake vNumber CBOR.Term) - -> VersionDataCodec CBOR.Term vNumber vData - -> HandshakeCallbacks vData - -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString IO b) - -- ^ The mux application that will be run on each incoming connection from - -- a given address. Note that if @'MuxClientAndServerApplication'@ is - -- returned, the connection will run a full duplex set of mini-protocols. - -> ErrorPolicies - -> (addr -> Async IO Void -> IO t) - -- ^ callback which takes the @Async@ of the thread that is running the server. - -- Note: the server thread will terminate when the callback returns or - -- throws an exception. - -> IO t -withServerNode' sn makeBearer - tracers - networkState - acceptedConnectionsLimit - sd - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies - k = do - addr' <- Snocket.getLocalAddr sn sd - withAsync - (runServerThread - tracers - networkState - sn - makeBearer - sd - acceptedConnectionsLimit - handshakeCodec - handshakeTimeLimits - versionDataCodec - handshakeCallbacks - versions - errorPolicies) - (k addr') diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs deleted file mode 100644 index 0e8838fcd78..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Public interface of 'Ouroboros.Network.Subscription' workers. --- -module Ouroboros.Network.Subscription - ( -- * IP Subscription Worker - ipSubscriptionWorker - , IPSubscriptionTarget (..) - -- * DNS Subscription Worker - , dnsSubscriptionWorker - , DnsSubscriptionTarget (..) - , ConnectResult (..) - -- * Constants - , defaultConnectionAttemptDelay - , minConnectionAttemptDelay - , maxConnectionAttemptDelay - , ipRetryDelay - , resolutionDelay - -- * Errors - , SubscriberError (..) - -- * Tracing - , SubscriptionTrace (..) - , WithIPList (..) - , DnsTrace (..) - , WithDomainName (..) - ) where - -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.Worker diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs deleted file mode 100644 index cb28902c1a9..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - --- Subscription worker for client applications connecting with 'LocalSnocket' --- which is using either unix sockets or Windows' named pipes. --- -module Ouroboros.Network.Subscription.Client - ( ClientSubscriptionParams (..) - , clientSubscriptionWorker - ) where - -import Control.Monad.Class.MonadTime.SI -import Control.Tracer - -import Data.Functor.Identity (Identity (..)) -import Data.Void (Void) - -import Ouroboros.Network.ErrorPolicy (ErrorPolicies, ErrorPolicyTrace, WithAddr, - completeApplicationTx) -import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket) -import Ouroboros.Network.Socket (NetworkMutableState (..)) -import Ouroboros.Network.Subscription.Ip (mainTx, socketStateChangeTx) -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker - - -data ClientSubscriptionParams a = ClientSubscriptionParams - { cspAddress :: !LocalAddress - -- ^ unix socket or named pipe address - , cspConnectionAttemptDelay :: !(Maybe DiffTime) - -- ^ delay between connection attempts - , cspErrorPolicies :: !ErrorPolicies - -- ^ error policies for subscription worker - } - --- | Client subscription worker keeps subscribing to the 'LocalAddress' using --- either unix socket or named pipe. --- -clientSubscriptionWorker - :: LocalSnocket - -> Tracer IO (SubscriptionTrace LocalAddress) - -> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace) - -> NetworkMutableState LocalAddress - -> ClientSubscriptionParams a - -> (LocalSocket -> IO a) - -> IO Void -clientSubscriptionWorker snocket - tracer - errorPolicyTracer - NetworkMutableState { nmsConnectionTable, nmsPeerStates } - ClientSubscriptionParams { cspAddress - , cspConnectionAttemptDelay - , cspErrorPolicies - } - k = - worker tracer - errorPolicyTracer - nmsConnectionTable - nmsPeerStates - snocket - mempty - WorkerCallbacks - { wcSocketStateChangeTx = socketStateChangeTx - , wcCompleteApplicationTx = completeApplicationTx cspErrorPolicies - , wcMainTx = mainTx - } - workerParams - k - where - workerParams :: WorkerParams IO Identity LocalAddress - workerParams = WorkerParams { - wpLocalAddresses = Identity cspAddress, - wpSelectAddress = \_ (Identity addr) -> Just addr, - wpConnectionAttemptDelay = const cspConnectionAttemptDelay, - wpSubscriptionTarget = pure (listSubscriptionTarget [cspAddress]), - wpValency = 1 - } diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs deleted file mode 100644 index 6a4c4f23935..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -{- Partial implementation of RFC8305, https://tools.ietf.org/html/rfc8305 . - - Prioritization of destination addresses doesn't implement longest prefix matching - - and doesn't take address scope etc. into account. - -} - -module Ouroboros.Network.Subscription.Dns - ( DnsSubscriptionTarget (..) - , Resolver (..) - , DnsSubscriptionParams - , dnsSubscriptionWorker' - , dnsSubscriptionWorker - , dnsResolve - , resolutionDelay - -- * Traces - , SubscriptionTrace (..) - , DnsTrace (..) - , ErrorPolicyTrace (..) - , WithDomainName (..) - , WithAddr (..) - ) where - -import Control.Concurrent.Class.MonadSTM qualified as Lazy -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Tracer -import Data.IP qualified as IP -import Data.Maybe (isJust) -import Data.Void (Void) -import Network.DNS qualified as DNS -import Network.Socket qualified as Socket -import Text.Printf - -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Snocket (Snocket) -import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker - - --- | Time to wait for an AAAA response after receiving an A response. -resolutionDelay :: DiffTime -resolutionDelay = 0.05 -- 50ms delay - - -data DnsSubscriptionTarget = DnsSubscriptionTarget { - dstDomain :: !DNS.Domain - , dstPort :: !Socket.PortNumber - , dstValency :: !Int - } deriving (Eq, Show) - - -data Resolver m = Resolver { - lookupA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - , lookupAAAA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) - } - -withResolver :: Socket.PortNumber -> DNS.ResolvSeed -> (Resolver IO -> IO a) -> IO a -withResolver port rs k = do - DNS.withResolver rs $ \dnsResolver -> - k (Resolver - (ipv4ToSockAddr dnsResolver) - (ipv6ToSockAddr dnsResolver)) - where - ipv4ToSockAddr dnsResolver d = do - r <- DNS.lookupA dnsResolver d - case r of - (Right ips) -> return $ Right $ map (Socket.SockAddrInet port . - IP.toHostAddress) ips - (Left e) -> return $ Left e - - ipv6ToSockAddr dnsResolver d = do - r <- DNS.lookupAAAA dnsResolver d - case r of - (Right ips) -> return $ Right $ map (\ip -> Socket.SockAddrInet6 port 0 (IP.toHostAddress6 ip) 0) ips - (Left e) -> return $ Left e - - -dnsResolve :: forall a m s. - ( MonadAsync m - , MonadCatch m - , MonadTimer m - ) - => Tracer m DnsTrace - -> m a - -> (a -> (Resolver m -> m (SubscriptionTarget m Socket.SockAddr)) -> m (SubscriptionTarget m Socket.SockAddr)) - -> StrictTVar m s - -> BeforeConnect m s Socket.SockAddr - -> DnsSubscriptionTarget - -> m (SubscriptionTarget m Socket.SockAddr) -dnsResolve tracer getSeed withResolverFn peerStatesVar beforeConnect (DnsSubscriptionTarget domain _ _) = do - rs_e <- (Right <$> getSeed) `catches` - [ Handler (\ (e :: DNS.DNSError) -> - return (Left $ toException e) :: m (Either SomeException a)) - -- On windows getSeed fails with BadConfiguration if the network is down. - , Handler (\ (e :: IOError) -> - return (Left $ toException e) :: m (Either SomeException a)) - -- On OSX getSeed can fail with IOError if all network devices are down. - ] - case rs_e of - Left e -> do - traceWith tracer $ DnsTraceLookupException e - return $ listSubscriptionTarget [] - - Right rs -> do - withResolverFn rs $ \resolver -> do - -- Though the DNS lib does have its own timeouts, these do not work - -- on Windows reliably so as a workaround we add an extra layer - -- of timeout on the outside. - -- TODO: Fix upstream dns lib. - -- On windows the aid_ipv6 and aid_ipv4 threads are leaked incase - -- of an exception in the main thread. - res <- timeout 20 $ do - aid_ipv6 <- async $ resolveAAAA resolver - aid_ipv4 <- async $ resolveA resolver aid_ipv6 - rd_e <- waitEitherCatch aid_ipv6 aid_ipv4 - case rd_e of - Left r -> do - traceWith tracer DnsTraceLookupIPv6First - handleThreadResult r $ threadTargetCycle aid_ipv4 - Right r -> do - traceWith tracer DnsTraceLookupIPv4First - handleThreadResult r $ threadTargetCycle aid_ipv6 - case res of - Nothing -> do - -- TODO: the thread timedout, we should trace it - return (SubscriptionTarget $ pure Nothing) - Just st -> - return (SubscriptionTarget $ pure st) - where - -- Creates a subscription target from an optional first socket and a tail - targetCons - :: Socket.SockAddr - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - targetCons addr next = do - b <- runBeforeConnect peerStatesVar beforeConnect addr - if b - then return $ Just (addr, SubscriptionTarget next) - else next - - -- Takes the result of a thread, returning an optional first socket in the subscription target result, - -- then calls the given function to get the tail - handleThreadResult - :: Either SomeException [Socket.SockAddr] - -> ([Socket.SockAddr] -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr))) - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - handleThreadResult (Left e) cont = do - traceWith tracer $ DnsTraceLookupException e - cont [] - handleThreadResult (Right []) cont = cont [] - handleThreadResult (Right (addr:addrs)) cont = targetCons addr $ cont addrs - - -- Called when a thread is still running, and the other finished already - -- Cycles between trying to get a result from the running thread, and the results of the finished thread - -- If results of the finished thread are exhausted, wait until the running thread completes - threadTargetCycle - :: Async m [Socket.SockAddr] - -> [Socket.SockAddr] - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - threadTargetCycle asyn [] = do - result <- waitCatch asyn - handleThreadResult result $ targetCycle [] - threadTargetCycle asyn a@(addr : addrs) = do - result <- poll asyn - case result of - -- The running thread finished, handle the result, then cycle over all results - Just r -> handleThreadResult r $ targetCycle a - -- The running thread is still going, emit an address of the finished thread, then check again - Nothing -> targetCons addr $ threadTargetCycle asyn addrs - - -- Called when both threads exited and we know the results of both. - -- Returns a subscription target that cycles between the results until both results are exhausted - targetCycle - :: [Socket.SockAddr] - -> [Socket.SockAddr] - -> m (Maybe (Socket.SockAddr, SubscriptionTarget m Socket.SockAddr)) - targetCycle as bs = go (as `interleave` bs) - where - go [] = return Nothing - go (x : xs) = targetCons x (go xs) - - interleave [] ys = ys - interleave (x : xs) ys = x : interleave ys xs - - resolveAAAA :: Resolver m - -> m [Socket.SockAddr] - resolveAAAA resolver = do - r_e <- lookupAAAA resolver domain - case r_e of - Left e -> do - traceWith tracer $ DnsTraceLookupAAAAError e - return [] - Right r -> do - traceWith tracer $ DnsTraceLookupAAAAResult r - - -- XXX Addresses should be sorted here based on DeltaQueue. - return r - - resolveA :: Resolver m - -> Async m [Socket.SockAddr] - -> m [Socket.SockAddr] - resolveA resolver aid_ipv6 = do - r_e <- lookupA resolver domain - case r_e of - Left e -> do - traceWith tracer $ DnsTraceLookupAError e - return [] - Right r -> do - traceWith tracer $ DnsTraceLookupAResult r - - {- From RFC8305. - - If a positive A response is received first due to reordering, the client - - SHOULD wait a short time for the AAAA response to ensure that preference is - - given to IPv6. - -} - timeoutVar <- registerDelay resolutionDelay - atomically $ do - timedOut <- Lazy.readTVar timeoutVar - ipv6Done <- pollSTM aid_ipv6 - check (timedOut || isJust ipv6Done) - - -- XXX Addresses should be sorted here based on DeltaQueue. - return r - - -dnsSubscriptionWorker' - :: Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) - -> Tracer IO (WithDomainName DnsTrace) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> IO b - -> (b -> (Resolver IO -> IO (SubscriptionTarget IO Socket.SockAddr)) - -> IO (SubscriptionTarget IO Socket.SockAddr)) - -> DnsSubscriptionParams a - -> Main IO (PeerStates IO Socket.SockAddr) x - -> (Socket.Socket -> IO a) - -> IO x -dnsSubscriptionWorker' snocket subTracer dnsTracer errorPolicyTracer - networkState@NetworkMutableState { nmsPeerStates } - setupResolver resolver - SubscriptionParams { spLocalAddresses - , spConnectionAttemptDelay - , spSubscriptionTarget = dst - , spErrorPolicies - } - main k = - subscriptionWorker snocket - (WithDomainName (dstDomain dst) `contramap` subTracer) - errorPolicyTracer - networkState - WorkerParams { wpLocalAddresses = spLocalAddresses - , wpConnectionAttemptDelay = spConnectionAttemptDelay - , wpSubscriptionTarget = - dnsResolve - (WithDomainName (dstDomain dst) `contramap` dnsTracer) - setupResolver resolver nmsPeerStates beforeConnectTx dst - , wpValency = dstValency dst - , wpSelectAddress = selectSockAddr - } - spErrorPolicies - main - k - - -type DnsSubscriptionParams a = SubscriptionParams a DnsSubscriptionTarget - -dnsSubscriptionWorker - :: Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) - -> Tracer IO (WithDomainName DnsTrace) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> DnsSubscriptionParams a - -> (Socket.Socket -> IO a) - -> IO Void -dnsSubscriptionWorker snocket subTracer dnsTracer errTrace networkState - params@SubscriptionParams { spSubscriptionTarget } k = - dnsSubscriptionWorker' - snocket - subTracer dnsTracer errTrace - networkState - (DNS.makeResolvSeed DNS.defaultResolvConf) - (withResolver (dstPort spSubscriptionTarget)) - params - mainTx - k - -data WithDomainName a = WithDomainName { - wdnDomain :: DNS.Domain - , wdnEvent :: a - } - -instance Show a => Show (WithDomainName a) where - show WithDomainName {wdnDomain, wdnEvent} = printf "Domain: %s %s" (show wdnDomain) (show wdnEvent) - -data DnsTrace = - DnsTraceLookupException SomeException - | DnsTraceLookupAError DNS.DNSError - | DnsTraceLookupAAAAError DNS.DNSError - | DnsTraceLookupIPv6First - | DnsTraceLookupIPv4First - | DnsTraceLookupAResult [Socket.SockAddr] - | DnsTraceLookupAAAAResult [Socket.SockAddr] - -instance Show DnsTrace where - show (DnsTraceLookupException e) = "lookup exception " ++ show e - show (DnsTraceLookupAError e) = "A lookup failed with " ++ show e - show (DnsTraceLookupAAAAError e) = "AAAA lookup failed with " ++ show e - show DnsTraceLookupIPv4First = "Returning IPv4 address first" - show DnsTraceLookupIPv6First = "Returning IPv6 address first" - show (DnsTraceLookupAResult as) = "Lookup A result: " ++ show as - show (DnsTraceLookupAAAAResult as) = "Lookup AAAAA result: " ++ show as diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs deleted file mode 100644 index 3f1755c081d..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | IP subscription worker implentation. -module Ouroboros.Network.Subscription.Ip - ( SubscriptionParams (..) - , IPSubscriptionParams - , ipSubscriptionWorker - , subscriptionWorker - , IPSubscriptionTarget (..) - , ipSubscriptionTarget - -- * Traces - , SubscriptionTrace (..) - , ErrorPolicyTrace (..) - , WithIPList (..) - -- * 'PeerState' STM transactions - , BeforeConnect - , runBeforeConnect - , beforeConnectTx - , completeApplicationTx - , socketStateChangeTx - , mainTx - -- * Utilitity functions - , selectSockAddr - ) where - - -{- The parallel connection attemps implemented in this module is inspired by - - RFC8305, https://tools.ietf.org/html/rfc8305 . - -} - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Tracer -import Data.Void (Void) -import Network.Socket qualified as Socket -import Text.Printf - -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Snocket (Snocket) -import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.PeerState -import Ouroboros.Network.Subscription.Subscriber -import Ouroboros.Network.Subscription.Worker - - -data IPSubscriptionTarget = IPSubscriptionTarget { - -- | List of destinations to possibly connect to - ispIps :: ![Socket.SockAddr] - -- | Number of parallel connections to keep actice. - , ispValency :: !Int - } deriving (Eq, Show) - - --- | 'ipSubscriptionWorker' and 'dnsSubscriptionWorker' parameters --- -data SubscriptionParams a target = SubscriptionParams - { spLocalAddresses :: LocalAddresses Socket.SockAddr - , spConnectionAttemptDelay :: Socket.SockAddr -> Maybe DiffTime - -- ^ should return expected delay for the given address - , spErrorPolicies :: ErrorPolicies - , spSubscriptionTarget :: target - } - -type IPSubscriptionParams a = SubscriptionParams a IPSubscriptionTarget - --- | Spawns a subscription worker which will attempt to keep the specified --- number of connections (Valency) active towards the list of IP addresses --- given in IPSubscriptionTarget. --- -ipSubscriptionWorker - :: forall a. - Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr)) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> IPSubscriptionParams a - -> (Socket.Socket -> IO a) - -> IO Void -ipSubscriptionWorker snocket subscriptionTracer errorPolicyTracer - networkState@NetworkMutableState { nmsPeerStates } - SubscriptionParams { spLocalAddresses - , spConnectionAttemptDelay - , spSubscriptionTarget - , spErrorPolicies - } - k = - subscriptionWorker snocket - subscriptionTracer' - errorPolicyTracer - networkState - workerParams - spErrorPolicies - mainTx - k - where - workerParams = WorkerParams { - wpLocalAddresses = spLocalAddresses, - wpConnectionAttemptDelay = spConnectionAttemptDelay, - wpSubscriptionTarget = - pure $ ipSubscriptionTarget subscriptionTracer' nmsPeerStates - (ispIps spSubscriptionTarget), - wpValency = ispValency spSubscriptionTarget, - wpSelectAddress = selectSockAddr - } - - subscriptionTracer' = (WithIPList spLocalAddresses (ispIps spSubscriptionTarget) - `contramap` subscriptionTracer) - -selectSockAddr :: Socket.SockAddr - -> LocalAddresses Socket.SockAddr - -> Maybe Socket.SockAddr -selectSockAddr Socket.SockAddrInet{} (LocalAddresses (Just localAddr) _ _ ) = Just localAddr -selectSockAddr Socket.SockAddrInet6{} (LocalAddresses _ (Just localAddr) _ ) = Just localAddr -selectSockAddr Socket.SockAddrUnix{} (LocalAddresses _ _ (Just localAddr) ) = Just localAddr -selectSockAddr _ _ = Nothing - - -ipSubscriptionTarget :: forall m addr. - ( MonadMonotonicTime m - , MonadSTM m - , Ord addr - ) - => Tracer m (SubscriptionTrace addr) - -> StrictTVar m (PeerStates m addr) - -> [addr] - -> SubscriptionTarget m addr -ipSubscriptionTarget tr peerStatesVar ips = go ips - where - go :: [addr] - -> SubscriptionTarget m addr - go [] = SubscriptionTarget $ pure Nothing - go (a : as) = SubscriptionTarget $ do - b <- runBeforeConnect peerStatesVar beforeConnectTx a - if b - then do - traceWith tr $ SubscriptionTraceTryConnectToPeer a - pure $ Just (a, go as) - else do - traceWith tr $ SubscriptionTraceSkippingPeer a - getSubscriptionTarget $ go as - - --- when creating a new socket: register consumer thread --- when tearing down a socket: unregister consumer thread -socketStateChangeTx - :: Ord addr - => SocketStateChange IO - (PeerStates IO addr) - addr - -socketStateChangeTx (CreatedSocket addr thread) ps = - pure (registerConsumer addr thread ps) - -socketStateChangeTx ClosedSocket{} ps@ThrowException{} = - pure ps - -socketStateChangeTx (ClosedSocket addr thread) ps = - pure $ unregisterConsumer addr thread ps - - --- | Main callback. It throws an exception when the state becomes --- 'ThrowException'. This exception is thrown from the main thread. --- -mainTx :: ( MonadThrow (STM m) - , MonadSTM m - ) - => Main m (PeerStates m addr) Void -mainTx (ThrowException e) = throwIO e -mainTx PeerStates{} = retry - - --- | Like 'worker' but in 'IO'; It provides address selection function, --- 'SocketStateChange' and 'CompleteApplication' callbacks. The 'Main' --- callback is left as it's useful for testing purposes. --- -subscriptionWorker - :: Snocket IO Socket.Socket Socket.SockAddr - -> Tracer IO (SubscriptionTrace Socket.SockAddr) - -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState Socket.SockAddr - -> WorkerParams IO LocalAddresses Socket.SockAddr - -> ErrorPolicies - -> Main IO (PeerStates IO Socket.SockAddr) x - -- ^ main callback - -> (Socket.Socket -> IO a) - -- ^ application to run on each connection - -> IO x -subscriptionWorker snocket - tracer - errorPolicyTracer - NetworkMutableState { nmsConnectionTable, nmsPeerStates } - workerParams - errorPolicies - main k = - worker tracer - errorPolicyTracer - nmsConnectionTable - nmsPeerStates - snocket - ((. Just) <$> configureSocket) - WorkerCallbacks - { wcSocketStateChangeTx = socketStateChangeTx - , wcCompleteApplicationTx = completeApplicationTx errorPolicies - , wcMainTx = main - } - workerParams - k - -data WithIPList a = WithIPList { - wilSrc :: (LocalAddresses Socket.SockAddr) - , wilDsts :: [Socket.SockAddr] - , wilEvent :: a - } - -instance (Show a) => Show (WithIPList a) where - show (WithIPList (LocalAddresses Nothing (Just ipv6) Nothing) wilDsts wilEvent) = - printf "IPs: %s %s %s" (show ipv6) (show wilDsts) (show wilEvent) - show (WithIPList (LocalAddresses (Just ipv4) Nothing Nothing) wilDsts wilEvent) = - printf "IPs: %s %s %s" (show ipv4) (show wilDsts) (show wilEvent) - show (WithIPList (LocalAddresses Nothing Nothing (Just unix)) wilDsts wilEvent) = - printf "IPs: %s %s %s" (show unix) (show wilDsts) (show wilEvent) - show (WithIPList (LocalAddresses (Just ipv4) (Just ipv6) Nothing) wilDsts wilEvent) = - printf "IPs: %s %s %s %s" (show ipv4) (show ipv6) - (show wilDsts) (show wilEvent) - show WithIPList {wilSrc, wilDsts, wilEvent} = - printf "IPs: %s %s %s" (show wilSrc) (show wilDsts) (show wilEvent) - diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs deleted file mode 100644 index 93cf0fe8f73..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs +++ /dev/null @@ -1,599 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module contains peer state management and error policies. --- -module Ouroboros.Network.Subscription.PeerState - ( SuspendDecision (..) - , suspend - -- * PeerStates and its operations - , PeerState (..) - , threadsToCancel - , PeerStates (..) - , newPeerStatesVar - , newPeerStatesVarSTM - , cleanPeerStates - , runSuspendDecision - , registerConsumer - , unregisterConsumer - , registerProducer - , unregisterProducer - , BeforeConnect - , ConnectDecision (..) - , runBeforeConnect - , beforeConnectTx - -- * Re-exports - , DiffTime - -- * Auxiliary functions - , alterAndLookup - ) where - -import Control.Exception (Exception, SomeException (..), assert) -import Control.Monad.State -import Data.Map qualified as Map -import Data.Map.Strict (Map) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Typeable (eqT, (:~:) (..)) - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI - -import Data.Semigroup.Action - --- | Semigroup of commands which acts on 'PeerState'. The @t@ variable might --- be initiated to 'DiffTime' or @Time m@. --- --- This semigroup allows to either suspend both consumer and producer or just --- the consumer part. --- -data SuspendDecision t - = SuspendPeer !t !t - -- ^ peer is suspend; The first @t@ is the time until which a local - -- producer is suspended, the second one is the time until which a local - -- consumer is suspended. - | SuspendConsumer !t - -- ^ suspend local consumer \/ initiator side until @t@ (this mean we are - -- not allowing to communicate with the producer \/ responder of a remote - -- peer). - | Throw - -- ^ throw an error from the main thread. - deriving (Eq, Ord, Show, Functor) - -consumerSuspendedUntil :: SuspendDecision t -> Maybe t -consumerSuspendedUntil (SuspendPeer _ consT) = Just consT -consumerSuspendedUntil (SuspendConsumer consT) = Just consT -consumerSuspendedUntil Throw = Nothing - -producerSuspendedUntil :: SuspendDecision t -> Maybe t -producerSuspendedUntil (SuspendPeer prodT _) = Just prodT -producerSuspendedUntil (SuspendConsumer _) = Nothing -producerSuspendedUntil Throw = Nothing - --- | The semigroup instance. Note that composing 'SuspendPeer' with --- 'SuspendConsumer' gives 'SuspendPeer'. 'SuspendPeer' and 'SuspendConsumer' --- form a sub-semigroup. --- -instance Ord t => Semigroup (SuspendDecision t) where - Throw <> _ = Throw - _ <> Throw = Throw - SuspendPeer prodT consT <> SuspendPeer prodT' consT' - = SuspendPeer (prodT `max` prodT') (consT `max` consT') - SuspendConsumer consT <> SuspendPeer prodT consT' - = SuspendPeer prodT (consT `max` consT') - SuspendPeer prodT consT <> SuspendConsumer consT' - = SuspendPeer prodT (consT `max` consT') - SuspendConsumer consT <> SuspendConsumer consT' - = SuspendConsumer (consT `max` consT') - - -data PeerState m - = HotPeer !(Set (Async m ())) !(Set (Async m ())) - -- ^ active peer with its producers and consumer threads - | SuspendedConsumer !(Set (Async m ())) !Time - -- ^ suspended consumer: with producer threads and time until the consumer is - -- suspended - | SuspendedPeer !Time !Time - -- ^ suspended peer: producer & consumer suspend time - | ColdPeer - -- ^ peer with no opened connections in either direction - -instance ( MonadAsync m - ) => Show (PeerState m) where - show (HotPeer producers consumers) - = "HotPeer" - ++ " " - ++ show (Set.map asyncThreadId producers) - ++ " " - ++ show (Set.map asyncThreadId consumers) - show (SuspendedConsumer producers consT) - = "SuspendedConsumer" - ++ " " - ++ show (Set.map asyncThreadId producers) - ++ " " - ++ show consT - show (SuspendedPeer prodT consT) - = "SuspendedPeer" - ++ " " - ++ show prodT - ++ " " - ++ show consT - show ColdPeer = "ColdPeer" - -deriving instance Eq (Async m ()) => Eq (PeerState m) - -deriving instance Ord (Async m ()) => Ord (PeerState m) - --- | Action of 'SuspendDecision' on @Maybe 'PeerState'@. We use this action --- together with 'Map.alter' function. --- --- Note: 'SuspendDecision' does not act on 'PeerState', only the sub-semigroup --- generated by 'SuspendConsumer' and 'SuspendPeer' does. --- --- -instance SAct (SuspendDecision Time) (Maybe (PeerState m)) where - - -- this means we will remove the entry from the state map; this is fine - -- since we are about to throw an exception to kill a node. - _ <| Throw = Nothing - Nothing <| _ = Nothing - - -- this might apply when a connection to a 'ColdPeer' thrown an - -- exception. - (Just ColdPeer) <| (SuspendConsumer consT) - = Just $ SuspendedConsumer Set.empty consT - (Just ColdPeer) <| (SuspendPeer prodT consT) - = Just (SuspendedPeer prodT consT) - - (Just (HotPeer producers _consumers)) <| (SuspendConsumer consT) - = Just $ SuspendedConsumer producers consT - (Just (HotPeer _prodcuers _consumers)) <| (SuspendPeer prodT consT) - = Just $ SuspendedPeer prodT consT - - (Just (SuspendedConsumer producers consT)) <| (SuspendConsumer consT') - = Just $ SuspendedConsumer producers (consT `max` consT') - (Just (SuspendedConsumer _producers consT)) <| (SuspendPeer prodT consT') - = Just $ SuspendedPeer prodT (consT `max` consT') - - (Just (SuspendedPeer prodT consT)) <| cmd - = case producerSuspendedUntil cmd of - Nothing -> - Just $ SuspendedPeer - prodT - (maybe consT (consT `max`) $ consumerSuspendedUntil cmd) - Just prodT' -> - Just $ SuspendedPeer - (prodT `max` prodT') - (maybe consT (consT `max`) $ consumerSuspendedUntil cmd) - --- | Threads which needs to be cancelled when updating the 'PeerState' with --- 'SuspendDecision'. --- -threadsToCancel :: Ord (Async m ()) - => PeerState m - -> SuspendDecision diffTime - -> Set (Async m ()) -threadsToCancel _ Throw - = Set.empty -threadsToCancel ColdPeer _ - = Set.empty -threadsToCancel (HotPeer _producers consumers) SuspendConsumer{} - = consumers -threadsToCancel (HotPeer consumers producers) SuspendPeer{} - = consumers <> producers -threadsToCancel SuspendedConsumer{} SuspendConsumer{} - = Set.empty -threadsToCancel (SuspendedConsumer producers _consT) SuspendPeer{} - = producers -threadsToCancel SuspendedPeer{} _cmd - = Set.empty - - --- | Action of 'SuspendDecision' on @Maybe 'PeerState'@. Action laws are only --- satisfied for the submonoid form by 'SuspendPeer' and 'SuspendConsumer'. --- -suspend :: Ord (Async m ()) - => Maybe (PeerState m) - -> SuspendDecision Time - -> ( Set (Async m ()) - , Maybe (PeerState m) - ) -suspend mbps cmd = ( maybe Set.empty (`threadsToCancel` cmd) mbps - , mbps <| cmd - ) - - --- | Map from addresses to 'PeerState's; it will be be shared in a 'StrictTVar'. --- --- Abstracting @t@ is useful for tests, the @IO@ version will use @Time IO@. --- -data PeerStates m addr where - -- | Map of peer states - PeerStates :: !(Map addr (PeerState m)) - -> PeerStates m addr - - -- | Or an exception to throw - ThrowException :: Exception e - => e - -> PeerStates m addr - -instance Show addr - => Show (PeerStates IO addr) where - show (PeerStates ps) = "PeerStates " ++ show ps - show (ThrowException e) = "ThrowException " ++ show e - --- TODO: move to Test.PeerStates as eqPeerStates -instance Eq addr - => Eq (PeerStates IO addr) where - ThrowException (_ :: e) == ThrowException (_ :: e') = - case eqT :: Maybe (e :~: e') of - Nothing -> False - Just Refl -> True - PeerStates ps == PeerStates ps' = ps == ps' - _ == _ = False - - -newPeerStatesVarSTM :: MonadSTM m => STM m (StrictTVar m (PeerStates m addr)) -newPeerStatesVarSTM = newTVar (PeerStates Map.empty) - -newPeerStatesVar :: MonadSTM m => m (StrictTVar m (PeerStates m addr)) -newPeerStatesVar = atomically newPeerStatesVarSTM - - --- | Periodically clean 'PeerState'. It will stop when 'PeerState' becomes --- 'ThrowException'. --- -cleanPeerStates :: ( MonadDelay m - , MonadTimer m - ) - => DiffTime - -> StrictTVar m (PeerStates m addr) - -> m () -cleanPeerStates interval v = go - where - go = do - threadDelay interval - t <- getMonotonicTime - continue <- atomically $ do - s <- readTVar v - case s of - ThrowException _ - -> pure False - PeerStates ps - -> True <$ (writeTVar v $! (PeerStates $ Map.mapMaybe (cleanPeerState t) ps)) - - if continue - then go - else pure () - - - cleanPeerState :: Time -> PeerState m -> Maybe (PeerState m) - cleanPeerState _t ColdPeer{} = Nothing - cleanPeerState _ ps@HotPeer{} = Just ps - cleanPeerState t ps@(SuspendedConsumer producers consT) - | Set.null producers && consT >= t - -- the consumer is not suspended anymore, but there is no producer thread - -- running, we can safely remove the peer from 'PeerStates' - = Nothing - - | consT >= t - -- the consumer is not suspended anymore, there are running producer - -- threads, and thus return a 'HotPeer'. - = Just (HotPeer producers Set.empty) - - | otherwise - -- otherwise the consumer is still supsended - = Just ps - - cleanPeerState t ps@(SuspendedPeer prodT consT) - | prodT < t - -- the producer is still suspended - = Just ps - - | consT < t - -- only the consumer is still suspended - = Just (SuspendedConsumer Set.empty consT) - - | otherwise - -- the peer is not suspended any more - = Nothing - - - --- | Update 'PeerStates' for a given 'addr', using 'suspend', and return --- threads which must be cancelled. --- --- This is more efficient that using the action of 'SuspendDecision' on --- 'PeerStates', since it only uses a single dictionary lookup to update the --- state and return the set of threads to be cancelled. --- -runSuspendDecision - :: forall m addr e. - ( Ord addr - , Ord (Async m ()) - , Exception e - ) - => Time - -> addr - -> e - -> SuspendDecision DiffTime - -> PeerStates m addr - -> ( PeerStates m addr - , Set (Async m ()) - ) -runSuspendDecision _t _addr _e _cmd ps0@ThrowException{} = - ( ps0 - , Set.empty - ) -runSuspendDecision _t _addr e Throw _ = - ( ThrowException (SomeException e) - , Set.empty - ) -runSuspendDecision t addr _e cmd (PeerStates ps0) = - gn $ alterAndLookup fn addr ps0 - where - fn :: Maybe (PeerState m) - -> ( Set (Async m ()) - , Maybe (PeerState m) - ) - fn mbps = ( maybe Set.empty (`threadsToCancel` cmd) mbps - , mbps <| (flip addTime t <$> cmd) - ) - - gn :: ( Map addr (PeerState m) - , Maybe (Set (Async m ())) - ) - -> ( PeerStates m addr - , Set (Async m ()) - ) - gn (ps, Nothing) = (PeerStates ps, Set.empty) - gn (ps, Just s) = (PeerStates ps, s) - - - --- Using pure 'State' monad and 'alterF' to avoid searching the 'PeerState' --- twice. -alterAndLookup - :: forall k s a. - Ord k - => (Maybe a -> (s, Maybe a)) - -> k - -> Map k a - -> ( Map k a - , Maybe s - ) -alterAndLookup f k m = runState (Map.alterF g k m) Nothing - where - g :: Maybe a -> State (Maybe s) (Maybe a) - g mba = case f mba of - (s, mba') -> mba' <$ modify' (const (Just s)) - - --- --- Various callbacks --- - - --- | Register producer in PeerStates. This is a partial function which assumes --- that the 'PeerState' is either 'HotPeer' or 'SuspendedConsumer'. --- -registerProducer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -registerProducer _addr _tid ps@ThrowException{} = ps -registerProducer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = - Just (HotPeer (Set.singleton tid) Set.empty) - fn (Just (HotPeer producers consumers)) = - Just (HotPeer (tid `Set.insert` producers) consumers) - fn (Just ColdPeer) = - Just (HotPeer (Set.singleton tid) Set.empty) - fn (Just (SuspendedConsumer producers consT)) = - Just (SuspendedConsumer (tid `Set.insert` producers) consT) - fn (Just ps@SuspendedPeer{}) = - -- registerProducer on a suspended peer - assert False $ Just ps - -unregisterProducer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -unregisterProducer _addr _tid ps@ThrowException{} = ps -unregisterProducer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = Nothing - fn (Just (HotPeer producers consumers)) = - let producers' = tid `Set.delete` producers - in if Set.null producers' && Set.null consumers - then Nothing - else Just (HotPeer producers' consumers) - fn (Just ColdPeer) = Nothing - fn (Just p@SuspendedPeer{}) = Just p - fn (Just (SuspendedConsumer producers consT)) = - Just (SuspendedConsumer (tid `Set.delete` producers) consT) - - --- | Register consumer in 'PeerState'. This is a partial function which --- assumes that the 'PeerState' is 'HotPeer'. --- -registerConsumer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -registerConsumer _addr _tid ps@ThrowException{} = ps -registerConsumer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = - Just (HotPeer Set.empty (Set.singleton tid)) - fn (Just (HotPeer producers consumers)) = - Just (HotPeer producers (tid `Set.insert` consumers)) - fn (Just ColdPeer) = - Just (HotPeer Set.empty (Set.singleton tid)) - fn (Just ps) = - -- registerConsumer on a suspended peer - assert False $ Just ps - - --- | Unregister consumer from a 'PeerState'. --- -unregisterConsumer :: forall m addr. - ( Ord addr - , Ord (Async m ()) - ) - => addr - -> Async m () - -> PeerStates m addr - -> PeerStates m addr -unregisterConsumer _addr _tid ps@ThrowException{} = ps -unregisterConsumer addr tid (PeerStates peerStates) = - PeerStates $ Map.alter fn addr peerStates - where - fn :: Maybe (PeerState m) -> Maybe (PeerState m) - fn Nothing = Nothing - fn (Just (HotPeer producers consumers)) = - let consumers' = tid `Set.delete` consumers - in if Set.null producers && Set.null consumers' - then Nothing - else Just (HotPeer producers consumers') - fn (Just ColdPeer) = Nothing - fn (Just ps) = Just ps - - --- | Before connectin with a peer we make a decision to either connect to it or --- not. --- -data ConnectDecision s - = AllowConnection !s - | DisallowConnection !s - | OnlyAccept !s - deriving Functor - --- | Check state before connecting to a remote peer. We will connect only if --- it retuns 'True'. --- -type BeforeConnect m s addr = Time -> addr -> s -> STM m (ConnectDecision s) - --- | Run 'BeforeConnect' callback in a 'MonadTime' monad. --- -runBeforeConnect :: ( MonadMonotonicTime m - , MonadSTM m - ) - => StrictTVar m s - -> BeforeConnect m s addr - -> addr - -> m Bool -runBeforeConnect sVar beforeConnect addr = do - t <- getMonotonicTime - atomically $ do - d <- readTVar sVar >>= beforeConnect t addr - case d of - AllowConnection s -> True <$ writeTVar sVar s - DisallowConnection s -> False <$ writeTVar sVar s - OnlyAccept s -> False <$ writeTVar sVar s - - --- | 'BeforeConnect' callback: it updates peer state and return boolean value --- wheather to connect to it or not. If a peer hasn't been recorded in --- 'PeerStates', we add it and try to connect to it. --- -beforeConnectTx - :: forall m addr. - ( MonadSTM m - , Ord addr - ) - => BeforeConnect m - (PeerStates m addr) - addr - -beforeConnectTx _t _addr ps@ThrowException{} = pure $ DisallowConnection ps - -beforeConnectTx t addr (PeerStates s) = - case alterAndLookup fn addr s of - (s', mbd) -> case mbd of - Nothing -> pure $ DisallowConnection (PeerStates s') - Just d -> pure (PeerStates s' <$ d) - where - fn :: Maybe (PeerState m) - -> ( ConnectDecision () - , Maybe (PeerState m) - ) - - -- we see the peer for the first time; consider it as a good peer and - -- try to connect to it. - fn Nothing = ( AllowConnection () - , Just ColdPeer - ) - - fn (Just p@ColdPeer{}) = ( AllowConnection () - , Just p - ) - - fn (Just p@(HotPeer producers consumers)) - = if Set.null producers && Set.null consumers - -- the peer has no registered producers nor consumers, thus it should - -- be marked as a 'ColdPeer' - then ( AllowConnection () - , Just ColdPeer - ) - else ( AllowConnection () - , Just p - ) - - fn (Just p@(SuspendedConsumer producers consT)) = - if consT < t - then if Set.null producers - -- the consumer is not suspended any longer, and it has no - -- producers; thus it's a 'ColdPeer'. - then (AllowConnection (), Just ColdPeer) - else (AllowConnection (), Just (HotPeer producers Set.empty)) - else (DisallowConnection (), Just p) - - fn (Just p@(SuspendedPeer prodT consT)) = - if t < prodT `max` consT - then if t < prodT `min` consT - then (DisallowConnection (), Just p) - else if prodT < consT - then -- prodT ≤ t < consT - -- allow the remote peer to connect to us, but we're - -- still not allowed to connect to it. - (OnlyAccept (), Just $ SuspendedConsumer Set.empty consT) - else -- consT ≤ t < prodT - -- the local consumer is suspended shorter than local - -- producer; In this case we suspend both until `prodT`. - -- This means we effectively make local consumer - -- errors more sevier than the ones which come from - -- a local producer. - (DisallowConnection (), Just $ SuspendedPeer prodT prodT) - - -- the peer is not suspended any longer - else (AllowConnection (), Just ColdPeer) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs deleted file mode 100644 index 464257f9b8d..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Subscriber.hs +++ /dev/null @@ -1,21 +0,0 @@ - -module Ouroboros.Network.Subscription.Subscriber - ( SubscriptionTarget (..) - , listSubscriptionTarget - ) where - --- | Generate subscription targets in some monad. --- Examples include obtaining targets from a fixed list, or from a DNS lookup. -newtype SubscriptionTarget m target = SubscriptionTarget - { getSubscriptionTarget :: m (Maybe (target, SubscriptionTarget m target)) - -- ^ This should be used with the exception that implementations can block on - -- the order of seconds. - } - -listSubscriptionTarget - :: Applicative m - => [target] - -> SubscriptionTarget m target -listSubscriptionTarget [] = SubscriptionTarget $ pure Nothing -listSubscriptionTarget (t:ts) = SubscriptionTarget $ pure (Just (t, listSubscriptionTarget ts)) - diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs deleted file mode 100644 index 8d0563e7d3a..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs +++ /dev/null @@ -1,670 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Ouroboros.Network.Subscription.Worker - ( SocketStateChange - , SocketState (..) - , CompleteApplication - , ConnectResult (..) - , Result (..) - , Main - , StateVar - , LocalAddresses (..) - -- * Subscription worker - , WorkerCallbacks (..) - , WorkerParams (..) - , worker - -- * Socket API - , safeConnect - -- * Constants - , defaultConnectionAttemptDelay - , minConnectionAttemptDelay - , maxConnectionAttemptDelay - , ipRetryDelay - -- * Errors - , SubscriberError (..) - -- * Tracing - , SubscriptionTrace (..) - ) where - -import Control.Applicative ((<|>)) -import Control.Concurrent.STM qualified as STM -import Control.Exception (SomeException (..)) -import Control.Monad (forever, join, unless, when) -import Control.Monad.Fix (MonadFix) -import Data.Foldable (traverse_) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Void (Void) -import GHC.Stack -import Network.Socket (Family (AF_UNIX)) -import Text.Printf - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Tracer - -import Ouroboros.Network.ErrorPolicy (CompleteApplication, - CompleteApplicationResult (..), ErrorPolicyTrace, Result (..), - WithAddr) -import Ouroboros.Network.Server.ConnectionTable -import Ouroboros.Network.Snocket (Snocket (..)) -import Ouroboros.Network.Snocket qualified as Snocket -import Ouroboros.Network.Subscription.Subscriber - --- | Time to wait between connection attempts when we don't have any DeltaQ --- info. --- -defaultConnectionAttemptDelay :: DiffTime -defaultConnectionAttemptDelay = 0.025 -- 25ms delay - --- | Minimum time to wait between connection attempts. --- -minConnectionAttemptDelay :: DiffTime -minConnectionAttemptDelay = 0.010 -- 10ms delay - --- | Maximum time to wait between connection attempts. --- -maxConnectionAttemptDelay :: DiffTime -maxConnectionAttemptDelay = 2 -- 2s delay - --- | Minimum time to wait between ip reconnects --- -ipRetryDelay :: DiffTime -ipRetryDelay = 10 -- 10s delay - -data ResOrAct m addr tr r = - Res !(Result addr r) - | Act (Set (Async m ())) -- ^ threads to kill - (Maybe tr) -- ^ trace point - --- | Result queue. The spawned threads will keep writing to it, while the main --- server will read from it. --- -type ResultQ m addr tr r = StrictTQueue m (ResOrAct m addr tr r) - -newResultQ :: forall m addr tr r. MonadSTM m => m (ResultQ m addr tr r) -newResultQ = atomically $ newTQueue - --- | Mutable state kept by the worker. All the workers in this module are --- polymorphic over the state type. The state is updated with two callbacks: --- --- * 'CompleteConnect' - STM transaction which runs when the connect call --- returned, if it thrown an exception it will be --- passed to the callback. --- * 'CompleteApplication' - STM transaction which runs when application --- returned. It will receive the result of the --- application or an exception raised by it. --- -type StateVar m s = StrictTVar m s - --- | The set of all spawned threads. Used for waiting or cancelling them when --- the server shuts down. --- -type ThreadsVar m = StrictTVar m (Set (Async m ())) - - -data SocketState m addr - = CreatedSocket !addr !(Async m ()) - | ClosedSocket !addr !(Async m ()) - --- | Callback which fires: when we create or close a socket. --- -type SocketStateChange m s addr = SocketState m addr -> s -> STM m s - --- | Given current state 'retry' too keep the subscription worker going. --- When this transaction returns, all the threads spawned by the worker will be --- killed. --- -type Main m s t = s -> STM m t - -data LocalAddresses addr = LocalAddresses { - -- | Local IPv4 address to use, Nothing indicates don't use IPv4 - laIpv4 :: Maybe addr - -- | Local IPv6 address to use, Nothing indicates don't use IPv6 - , laIpv6 :: Maybe addr - -- | Local Unix address to use, Nothing indicates don't use Unix sockets - , laUnix :: Maybe addr - } deriving (Eq, Show) - -instance Semigroup (LocalAddresses addr) where - a <> b = LocalAddresses { - laIpv4 = laIpv4 a <|> laIpv4 b, - laIpv6 = laIpv6 a <|> laIpv6 b, - laUnix = laUnix a <|> laUnix b - } - - --- | Allocate a socket and connect to a peer, execute the continuation with --- async exceptions masked. The continuation receives the 'unmask' callback. --- -safeConnect :: ( MonadMask m - ) - => Snocket m sock addr - -> (sock -> addr -> m ()) -- ^ configure the socket - -> addr - -- ^ remote addr - -> addr - -- ^ local addr - -> m () - -- ^ allocate extra action; executed with async exceptions masked in - -- the allocation action of 'bracket' - -> m () - -- ^ release extra action; executed with async exceptions masked in - -- the closing action of 'bracket' - -> ((forall x. m x -> m x) -> sock -> Either SomeException () -> m t) - -- ^ continuation executed with async exceptions - -- masked; it receives: unmask function, allocated socket and - -- connection error. - -> m t -safeConnect sn configureSock remoteAddr localAddr malloc mclean k = - bracket - (do sock <- Snocket.open sn (Snocket.addrFamily sn remoteAddr) - malloc - pure sock - ) - (\sock -> Snocket.close sn sock >> mclean) - (\sock -> mask $ \unmask -> do - res <- try $ do - configureSock sock localAddr - let doBind = case Snocket.addrFamily sn localAddr of - Snocket.SocketFamily fam -> fam /= AF_UNIX - _ -> False -- Bind is a nop for Named Pipes anyway - when doBind $ - Snocket.bind sn sock localAddr - unmask $ Snocket.connect sn sock remoteAddr - k unmask sock res) - - --- --- Internal API --- - - --- | GADT which classifies connection result. --- -data ConnectResult = - ConnectSuccess - -- ^ Successful connection. - | ConnectSuccessLast - -- ^ Successfully connection, reached the valency target. Other ongoing - -- connection attempts will be killed. - | ConnectValencyExceeded - -- ^ Someone else manged to create the final connection to a target before - -- us. - deriving (Eq, Ord, Show) - --- | Traverse 'SubscriptionTarget's in an infinite loop. --- -subscriptionLoop - :: forall m s sock localAddrs addr a x. - ( MonadAsync m - , MonadDelay m - , MonadMask m - , MonadFix m - , Ord (Async m ()) - , Ord addr - ) - => Tracer m (SubscriptionTrace addr) - - -- various state variables of the subscription loop - -> ConnectionTable m addr - -> ResultQ m addr (WithAddr addr ErrorPolicyTrace) a - -> StateVar m s - -> ThreadsVar m - - -> Snocket m sock addr - -> (sock -> addr -> m ()) - - -> WorkerCallbacks m s addr a x - -> WorkerParams m localAddrs addr - -- ^ given a remote address, pick the local one - -> (sock -> m a) - -- ^ application - -> m Void -subscriptionLoop - tr tbl resQ sVar threadsVar snocket configureSock - WorkerCallbacks { wcSocketStateChangeTx = socketStateChangeTx - , wcCompleteApplicationTx = completeApplicationTx - } - WorkerParams { wpLocalAddresses = localAddresses - , wpConnectionAttemptDelay = connectionAttemptDelay - , wpSubscriptionTarget = subscriptionTargets - , wpValency = valency - , wpSelectAddress - } - k = do - valencyVar <- atomically $ newValencyCounter tbl valency - - -- outer loop: set new 'conThread' variable, get targets and traverse - -- through them trying to connect to each addr. - forever $ do - traceWith tr (SubscriptionTraceStart valency) - start <- getMonotonicTime - conThreads <- newTVarIO Set.empty - sTarget <- subscriptionTargets - innerLoop conThreads valencyVar sTarget - atomically $ waitValencyCounter valencyVar - - -- We always wait at least 'ipRetryDelay' seconds between calls to - -- 'getTargets', and before trying to restart the subscriptions we also - -- wait 1 second so that if multiple subscription targets fail around the - -- same time we will try to restart with a valency - -- higher than 1. - threadDelay 1 - end <- getMonotonicTime - let duration = diffTime end start - currentValency <- atomically $ readValencyCounter valencyVar - traceWith tr $ SubscriptionTraceRestart duration valency - (valency - currentValency) - - when (duration < ipRetryDelay) $ - threadDelay $ ipRetryDelay - duration - - where - -- a single run through @sTarget :: SubscriptionTarget m addr@. - innerLoop :: StrictTVar m (Set (Async m ())) - -> ValencyCounter m - -> SubscriptionTarget m addr - -> m () - innerLoop conThreads valencyVar sTarget = do - mt <- getSubscriptionTarget sTarget - case mt of - Nothing -> do - len <- fmap length $ atomically $ readTVar conThreads - when (len > 0) $ - traceWith tr $ SubscriptionTraceSubscriptionWaiting len - - -- We wait on the list of active connection threads instead of using - -- an async wait function since some of the connections may succeed - -- and then should be left running. - -- - -- Note: active connections are removed from 'conThreads' when the - -- 'connect' call finishes. - atomically $ do - activeCons <- readTVar conThreads - unless (null activeCons) retry - - valencyLeft <- atomically $ readValencyCounter valencyVar - if valencyLeft <= 0 - then traceWith tr SubscriptionTraceSubscriptionRunning - else traceWith tr SubscriptionTraceSubscriptionFailed - - Just (remoteAddr, sTargetNext) -> do - valencyLeft <- atomically $ readValencyCounter valencyVar - - -- If we have already created enough connections (valencyLeft <= 0) - -- we don't need to traverse the rest of the list. - if valencyLeft <= 0 - then traceWith tr SubscriptionTraceSubscriptionRunning - else innerStep conThreads valencyVar remoteAddr sTargetNext - - innerStep :: StrictTVar m (Set (Async m ())) - -- ^ outstanding connection threads; threads are removed as soon - -- as the connection succeeds. They are all cancelled when - -- valency drops to 0. The asynchronous exception which cancels - -- the connection thread can only occur while connecting and not - -- when an application is running. This is guaranteed since - -- threads are removed from this set as soon connecting is - -- finished (successfully or not) and before application is - -- started. - -> ValencyCounter m - -> addr - -> SubscriptionTarget m addr - -> m () - innerStep conThreads valencyVar !remoteAddr sTargetNext = do - r <- refConnection tbl remoteAddr ConnectionOutbound valencyVar - case r of - ConnectionTableCreate -> - case wpSelectAddress remoteAddr localAddresses of - Nothing -> - traceWith tr (SubscriptionTraceUnsupportedRemoteAddr remoteAddr) - - -- This part is very similar to - -- 'Ouroboros.Network.Server.Socket.spawnOne', it should not - -- deadlock by the same reasons. The difference is that we are - -- using 'mask' and 'async' as 'asyncWithUnmask' is not available. - Just localAddr -> - do rec - thread <- async $ do - traceWith tr $ SubscriptionTraceConnectStart remoteAddr - -- Try to connect; 'safeConnect' is using 'bracket' to - -- create / close a socket and update the states. The - -- continuation, e.g. 'connAction' runs with async - -- exceptions masked, and receives the unmask function from - -- this bracket. - safeConnect - snocket - configureSock - remoteAddr - localAddr - (do - traceWith tr $ SubscriptionTraceAllocateSocket remoteAddr - atomically $ do - modifyTVar conThreads (Set.insert thread) - modifyTVar threadsVar (Set.insert thread) - readTVar sVar - >>= socketStateChangeTx (CreatedSocket remoteAddr thread) - >>= (writeTVar sVar $!)) - (do - atomically $ do - -- The thread is removed from 'conThreads' - -- inside 'connAction'. - modifyTVar threadsVar (Set.delete thread) - readTVar sVar - >>= socketStateChangeTx (ClosedSocket remoteAddr thread) - >>= (writeTVar sVar $!) - traceWith tr $ SubscriptionTraceCloseSocket remoteAddr) - (connAction - thread conThreads valencyVar - remoteAddr) - - let delay = case connectionAttemptDelay remoteAddr of - Just d -> d `max` minConnectionAttemptDelay - `min` maxConnectionAttemptDelay - Nothing -> defaultConnectionAttemptDelay - traceWith tr - (SubscriptionTraceSubscriptionWaitingNewConnection delay) - threadDelay delay - - ConnectionTableExist -> - traceWith tr $ SubscriptionTraceConnectionExist remoteAddr - ConnectionTableDuplicate -> pure () - innerLoop conThreads valencyVar sTargetNext - - -- Start connection thread: connect to the remote peer, run application. - -- This function runs with asynchronous exceptions masked. - -- - connAction :: Async m () - -> StrictTVar m (Set (Async m ())) - -> ValencyCounter m - -> addr - -> (forall y. m y -> m y) -- unmask exceptions - -> sock - -> Either SomeException () - -> m () - connAction thread conThreads valencyVar remoteAddr unmask sock connectionRes = do - t <- getMonotonicTime - case connectionRes of - -- connection error - Left (SomeException e) -> do - traceWith tr $ SubscriptionTraceConnectException remoteAddr e - atomically $ do - -- remove thread from active connections threads - modifyTVar conThreads (Set.delete thread) - - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- readTVar sVar >>= completeApplicationTx (ConnectionError t remoteAddr e) - writeTVar sVar carState - writeTQueue resQ (Act carThreads carTrace) - - -- connection succeeded - Right _ -> do - localAddr <- Snocket.getLocalAddr snocket sock - connRes <- atomically $ do - -- we successfully connected, remove the thread from - -- outstanding connection threads. - modifyTVar conThreads (Set.delete thread) - - v <- readValencyCounter valencyVar - if v > 0 - then do - addConnection tbl remoteAddr localAddr ConnectionOutbound (Just valencyVar) - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- readTVar sVar >>= completeApplicationTx (Connected t remoteAddr) - writeTVar sVar carState - writeTQueue resQ (Act carThreads carTrace) - return $ if v == 1 - then ConnectSuccessLast - else ConnectSuccess - else - return ConnectValencyExceeded - - -- handle connection result - traceWith tr $ SubscriptionTraceConnectEnd remoteAddr connRes - case connRes of - ConnectValencyExceeded -> pure () - -- otherwise it was a success - _ -> do - when (connRes == ConnectSuccessLast) $ do - -- outstanding connection threads - threads <- atomically $ readTVar conThreads - mapM_ (\tid -> - cancelWith tid - (SubscriberError - SubscriberParallelConnectionCancelled - "Parallel connection cancelled" - callStack) - )threads - - - -- run application - appRes :: Either SomeException a - <- try $ unmask (k sock) - - case appRes of - Right _ -> pure () - Left e -> traceWith tr $ SubscriptionTraceApplicationException remoteAddr e - - t' <- getMonotonicTime - atomically $ do - case appRes of - Right a -> - writeTQueue resQ (Res (ApplicationResult t' remoteAddr a)) - Left (SomeException e) -> - writeTQueue resQ (Res (ApplicationError t' remoteAddr e)) - removeConnectionSTM tbl remoteAddr localAddr ConnectionOutbound - --- | Almost the same as 'Ouroboros.Network.Server.Socket.mainLoop'. --- 'mainLoop' reads from the result queue and runs the 'CompleteApplication' --- callback. --- -mainLoop - :: forall s r addr t. - Tracer IO (WithAddr addr ErrorPolicyTrace) - -> ResultQ IO addr (WithAddr addr ErrorPolicyTrace) r - -> ThreadsVar IO - -> StateVar IO s - -> CompleteApplication IO s addr r - -> Main IO s t - -> IO t -mainLoop errorPolicyTracer resQ threadsVar statusVar completeApplicationTx main = do - join (atomically $ mainTx `STM.orElse` connectionTx) - where - -- Sample the state, and run the main action. If it does not retry, then - -- the `mainLoop` finishes with `pure t` where `t` is the main action result. - mainTx :: STM IO (IO t) - mainTx = do - t <- readTVar statusVar >>= main - pure $ pure t - - -- Wait for some connection to finish, update the state with its result, - -- then recurse onto `mainLoop`. - connectionTx :: STM IO (IO t) - connectionTx = do - result <- readTQueue resQ - case result of - Act threads tr -> pure $ do - traverse_ cancel threads - traverse_ (traceWith errorPolicyTracer) tr - mainLoop errorPolicyTracer resQ threadsVar statusVar completeApplicationTx main - Res r -> do - s <- readTVar statusVar - CompleteApplicationResult - { carState - , carThreads - , carTrace - } <- completeApplicationTx r s - writeTVar statusVar carState - pure $ do - traverse_ cancel carThreads - traverse_ (traceWith errorPolicyTracer) carTrace - mainLoop errorPolicyTracer resQ threadsVar statusVar completeApplicationTx main - - --- --- Worker --- - --- | Worker STM callbacks --- -data WorkerCallbacks m s addr a t = WorkerCallbacks { - wcSocketStateChangeTx :: SocketStateChange m s addr, - wcCompleteApplicationTx :: CompleteApplication m s addr a, - wcMainTx :: Main m s t - } - --- | Worker parameters --- -data WorkerParams m localAddrs addr = WorkerParams { - wpLocalAddresses :: localAddrs addr, - -- ^ local addresses of the server - wpSelectAddress :: addr -> localAddrs addr -> Maybe addr, - -- ^ given remote addr pick the local address - wpConnectionAttemptDelay :: addr -> Maybe DiffTime, - -- ^ delay after a connection attempt to 'addr' - wpSubscriptionTarget :: m (SubscriptionTarget m addr), - wpValency :: Int - } - --- | This is the most abstract worker, which puts all the pieces together. It --- will execute until @main :: Main m s t@ returns. It runs --- 'subscriptionLoop' in a new threads and will exit when it dies. Spawn --- threads are cancelled in a 'finally' callback by throwing 'SubscriberError'. --- --- Note: This function runs in 'IO' only because 'MonadSTM' does not yet support --- 'orElse', PR #432. --- -worker - :: forall s sock localAddrs addr a x. - Ord addr - => Tracer IO (SubscriptionTrace addr) - -> Tracer IO (WithAddr addr ErrorPolicyTrace) - -> ConnectionTable IO addr - -> StateVar IO s - - -> Snocket IO sock addr - -> (sock -> addr -> IO ()) - - -> WorkerCallbacks IO s addr a x - -> WorkerParams IO localAddrs addr - - -> (sock -> IO a) - -- ^ application - -> IO x -worker tr errTrace tbl sVar snocket configureSock workerCallbacks@WorkerCallbacks {wcCompleteApplicationTx, wcMainTx } workerParams k = do - resQ <- newResultQ - threadsVar <- newTVarIO Set.empty - withAsync - (subscriptionLoop tr tbl resQ sVar threadsVar snocket configureSock - workerCallbacks workerParams k) $ \_ -> - mainLoop errTrace resQ threadsVar sVar wcCompleteApplicationTx wcMainTx - `finally` killThreads threadsVar - where - killThreads threadsVar = do - let e = SubscriberError - SubscriberWorkerCancelled - "SubscriptionWorker exiting" - callStack - children <- atomically $ readTVar threadsVar - mapM_ (\a -> cancelWith a e) children - - --- --- Auxiliary types: errors, traces --- - -data SubscriberError = SubscriberError { - seType :: !SubscriberErrorType - , seMessage :: !String - , seStack :: !CallStack - } deriving Show - --- | Enumeration of error conditions. --- -data SubscriberErrorType = SubscriberParallelConnectionCancelled - | SubscriberWorkerCancelled - deriving (Eq, Show) - -instance Exception SubscriberError where - displayException SubscriberError{seType, seMessage, seStack} - = printf "%s %s at %s" - (show seType) - (show seMessage) - (prettyCallStack seStack) - - -data SubscriptionTrace addr = - SubscriptionTraceConnectStart addr - | SubscriptionTraceConnectEnd addr ConnectResult - | forall e. Exception e => SubscriptionTraceSocketAllocationException addr e - | forall e. Exception e => SubscriptionTraceConnectException addr e - | forall e. Exception e => SubscriptionTraceApplicationException addr e - | SubscriptionTraceTryConnectToPeer addr - | SubscriptionTraceSkippingPeer addr - | SubscriptionTraceSubscriptionRunning - | SubscriptionTraceSubscriptionWaiting Int - | SubscriptionTraceSubscriptionFailed - | SubscriptionTraceSubscriptionWaitingNewConnection DiffTime - | SubscriptionTraceStart Int - | SubscriptionTraceRestart DiffTime Int Int - | SubscriptionTraceConnectionExist addr - | SubscriptionTraceUnsupportedRemoteAddr addr - | SubscriptionTraceMissingLocalAddress - | SubscriptionTraceAllocateSocket addr - | SubscriptionTraceCloseSocket addr - -instance Show addr => Show (SubscriptionTrace addr) where - show (SubscriptionTraceConnectStart dst) = - "Connection Attempt Start, destination " ++ show dst - show (SubscriptionTraceConnectEnd dst res) = - "Connection Attempt End, destination " ++ show dst ++ " outcome: " ++ show res - show (SubscriptionTraceSocketAllocationException dst e) = - "Socket Allocation Exception, destination " ++ show dst ++ " exception: " ++ show e - show (SubscriptionTraceConnectException dst e) = - "Connection Attempt Exception, destination " ++ show dst ++ " exception: " ++ show e - show (SubscriptionTraceTryConnectToPeer addr) = - "Trying to connect to " ++ show addr - show (SubscriptionTraceSkippingPeer addr) = - "Skipping peer " ++ show addr - show SubscriptionTraceSubscriptionRunning = - "Required subscriptions started" - show (SubscriptionTraceSubscriptionWaiting d) = - "Waiting on " ++ show d ++ " active connections" - show SubscriptionTraceSubscriptionFailed = - "Failed to start all required subscriptions" - show (SubscriptionTraceSubscriptionWaitingNewConnection delay) = - "Waiting " ++ show delay ++ " before attempting a new connection" - show (SubscriptionTraceStart val) = "Starting Subscription Worker, valency " ++ show val - show (SubscriptionTraceRestart duration desiredVal currentVal) = - "Restarting Subscription after " ++ show duration ++ " desired valency " ++ - show desiredVal ++ " current valency " ++ show currentVal - show (SubscriptionTraceConnectionExist dst) = - "Connection Existed to " ++ show dst - show (SubscriptionTraceUnsupportedRemoteAddr dst) = - "Unsupported remote target address " ++ show dst - -- TODO: add address family - show SubscriptionTraceMissingLocalAddress = - "Missing local address" - show (SubscriptionTraceApplicationException addr e) = - "Application Exception: " ++ show addr ++ " " ++ show e - show (SubscriptionTraceAllocateSocket addr) = - "Allocate socket to " ++ show addr - show (SubscriptionTraceCloseSocket addr) = - "Closed socket to " ++ show addr diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs new file mode 100644 index 00000000000..9acb95e7477 --- /dev/null +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A simple server implemented for testing purposes +-- +-- The module should be imported qualified. +module Test.Ouroboros.Network.Server where + +import Control.Applicative (Alternative) +import Control.Concurrent.JobPool qualified as JobPool +import Control.Monad (forever) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork (MonadFork) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.Tracer (nullTracer) +import Data.ByteString.Lazy qualified as BL +import Data.Functor (void) +import Data.Typeable (Typeable) +import Data.Void (Void) + +import Network.Mux qualified as Mx + +import Ouroboros.Network.ConnectionId +import Ouroboros.Network.Mux +import Ouroboros.Network.Protocol.Handshake +import Ouroboros.Network.Snocket as Snocket +import Ouroboros.Network.Socket + + +with :: forall fd addr vNumber vData m a b. + ( Alternative (STM m), + MonadAsync m, + MonadFork m, + MonadLabelledSTM m, + MonadMask m, + MonadTimer m, + MonadThrow (STM m), + Ord vNumber, + Typeable vNumber, + Show vNumber + ) + => Snocket m fd addr + -> Mx.MakeBearer m fd + -> (fd -> addr -> m ()) + -> addr + -> HandshakeArguments (ConnectionId addr) vNumber vData m + -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString m b) + -> (addr -> Async m Void -> m a) + -> m a +with sn makeBearer configureSock addr handshakeArgs versions k = + JobPool.withJobPool $ \jobPool -> + bracket + (do sd <- Snocket.open sn (Snocket.addrFamily sn addr) + configureSock sd addr + Snocket.bind sn sd addr + Snocket.listen sn sd + addr' <- getLocalAddr sn sd + pure (sd, addr')) + (Snocket.close sn . fst) + (\(sock, addr') -> + -- accept loop + withAsync (forever $ acceptOne jobPool sock) (k addr') + ) + where + acceptOne :: JobPool.JobPool () m () -> fd -> m () + acceptOne jobPool sock = accept sn sock >>= runAccept >>= \case + (Accepted sock' remoteAddr, _) -> do + let connThread = do + -- connection responder thread + let connId = ConnectionId addr remoteAddr + bearer <- Mx.getBearer makeBearer + (-1) nullTracer sock' + configureSock sock' addr + r <- runHandshakeServer bearer connId handshakeArgs versions + case r of + Left (HandshakeProtocolLimit e) -> throwIO e + Left (HandshakeProtocolError e) -> throwIO e + Right HandshakeQueryResult {} -> error "handshake query is not supported" + Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do + mux <- Mx.new (toMiniProtocolInfos (runForkPolicy noBindForkPolicy (remoteAddress connId)) app) + withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + void $ simpleMuxCallback connId vNumber vData app mux aid + + errorHandler = \e -> throwIO e + + JobPool.forkJob jobPool + $ JobPool.Job connThread + errorHandler + () + "conn-thread" + (AcceptFailure e, _) -> throwIO e From bd5d3af1e10a97cc1aeb2efd25630a6b3fa062ef Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 4 Nov 2024 09:00:05 +0100 Subject: [PATCH 3/6] ouroboros-network: removed NonP2P components * Updated to compile with changes in the previous commit. * APIs removed from `Ouroboros.Network.{NodeToClient,NodeToNode}` modules: * NetworkServerTracers * NetworkMutableState APIs * withServer * ErrorPolicies * WithAddr * SuspendDecision * APIs removed from `Ouroboros.Network.NodeToNode` module: * IPSubscriptionTarget * NetworkIPSubscription * NetworkSubscriptionTracers * SubscriptionParams * DnsSubscriptionTarget * DnsSubscriptioinParams * NetworkDNSSubscriptionTracers * dnsSubscriptionWorker --- ouroboros-network/CHANGELOG.md | 16 + ouroboros-network/demo/chain-sync.hs | 45 +- .../io-tests/Test/Ouroboros/Network/Socket.hs | 30 +- ouroboros-network/ouroboros-network.cabal | 5 +- .../Test/Ouroboros/Network/PeerState.hs | 499 ------------------ ouroboros-network/sim-tests/Main.hs | 2 - .../src/Ouroboros/Network/NodeToClient.hs | 210 +------- .../src/Ouroboros/Network/NodeToNode.hs | 336 +----------- .../src/Ouroboros/Network/Tracers.hs | 81 --- 9 files changed, 60 insertions(+), 1164 deletions(-) delete mode 100644 ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs delete mode 100644 ouroboros-network/src/Ouroboros/Network/Tracers.hs diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 9204adac7ac..9da3c184792 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -199,6 +199,22 @@ ### Breaking changes +* APIs removed from `Ouroboros.Network.{NodeToClient,NodeToNode}` modules: + * NetworkServerTracers + * NetworkMutableState APIs + * withServer + * ErrorPolicies + * WithAddr + * SuspendDecision +* APIs removed from `Ouroboros.Network.NodeToNode` module: + * IPSubscriptionTarget + * NetworkIPSubscription + * NetworkSubscriptionTracers + * SubscriptionParams + * DnsSubscriptionTarget + * DnsSubscriptioinParams + * NetworkDNSSubscriptionTracers + * dnsSubscriptionWorker * Added `AcquireConnectionError` to `PeerSelectionActionsTrace` * Removed deprecated `ReconnectDelay` type alias. * Addapted to `network-mux` changes in https://github.com/IntersectMBO/ouroboros-network/pull/4999 diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 00fb264249f..c237335f078 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -59,6 +59,7 @@ import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Driver +import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version @@ -78,6 +79,8 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientRegistry (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) import Ouroboros.Network.DeltaQ (defaultGSV) +import Test.Ouroboros.Network.Server qualified as Test.Server + data Options = Options { oBlockFetch :: Bool, @@ -271,25 +274,23 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of Nothing -> initStdGen Just a -> return (mkStdGen a) - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (localSnocket iocp) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) (localAddressFromPath sockAddr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (simpleSingletonVersions UnversionedProtocol UnversionedProtocolData - (\_ -> SomeResponderApplication (app prng))) - nullErrorPolicies + (\_ -> SomeResponderApplication (app prng))) $ \_ serverAsync -> wait serverAsync -- block until async exception where @@ -547,25 +548,23 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of Nothing -> initStdGen Just a -> return (mkStdGen a) - networkState <- newNetworkMutableState - _ <- async $ cleanNetworkMutableState networkState - withServerNode + Test.Server.with (localSnocket iocp) makeLocalBearer mempty - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) (localAddressFromPath sockAddr) - unversionedHandshakeCodec - noTimeLimitsHandshake - unversionedProtocolDataCodec - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = unversionedProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + } (simpleSingletonVersions UnversionedProtocol UnversionedProtocolData (\_ -> SomeResponderApplication (app prng))) - nullErrorPolicies $ \_ serverAsync -> wait serverAsync -- block until async exception where diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs index 526069bf198..319e6b7eeb5 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs @@ -38,10 +38,12 @@ import Ouroboros.Network.Mock.Chain (Chain, ChainUpdate, Point) import Ouroboros.Network.Mock.Chain qualified as Chain import Ouroboros.Network.Mock.ProducerState qualified as CPS import Ouroboros.Network.NodeToNode +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Protocol.ChainSync.Client qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Codec qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Examples qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Server qualified as ChainSync +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, noTimeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, @@ -50,8 +52,8 @@ import Ouroboros.Network.Util.ShowProxy import Test.ChainGenerators (TestBlockChainAndUpdates (..)) import Test.Ouroboros.Network.Serialise +import Test.Ouroboros.Network.Server qualified as Test.Server -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) @@ -118,8 +120,7 @@ demo chain0 updates = withIOManager $ \iocp -> do producerVar <- newTVarIO (CPS.initChainProducerState chain0) consumerVar <- newTVarIO chain0 - done <- atomically newEmptyTMVar - networkState <- newNetworkMutableState + done <- newEmptyTMVarIO let Just expectedChain = Chain.applyChainUpdates updates chain0 target = Chain.headPoint expectedChain @@ -157,18 +158,20 @@ demo chain0 updates = withIOManager $ \iocp -> do encode decode (encodeTip encode) (decodeTip decode) - withServerNode + Test.Server.with (socketSnocket iocp) makeSocketBearer ((. Just) <$> configureSocket) - nullNetworkServerTracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) producerAddress - nodeToNodeHandshakeCodec - noTimeLimitsHandshake - (cborTermVersionDataCodec nodeToNodeCodecCBORTerm) - (HandshakeCallbacks acceptableVersion queryVersion) + HandshakeArguments { + haHandshakeTracer = nullTracer, + haHandshakeCodec = nodeToNodeHandshakeCodec, + haVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = noTimeLimitsHandshake + + } (simpleSingletonVersions (maxBound :: NodeToNodeVersion) (NodeToNodeVersionData { @@ -177,8 +180,7 @@ demo chain0 updates = withIOManager $ \iocp -> do peerSharing = PeerSharingDisabled, query = False }) (\_ -> SomeResponderApplication responderApp)) - nullErrorPolicies - $ \realProducerAddress _ -> do + $ \producerAddress' _ -> do withAsync (connectToNode (socketSnocket iocp) @@ -200,7 +202,7 @@ demo chain0 updates = withIOManager $ \iocp -> do query = False }) (\_ -> initiatorApp)) (Just consumerAddress) - realProducerAddress) + producerAddress') $ \ _connAsync -> do void $ forkIO $ sequence_ [ do diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 959920cdca6..20788fa2688 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -106,7 +106,6 @@ library Ouroboros.Network.PeerSelection.State.LocalRootPeers Ouroboros.Network.PeerSelection.Types Ouroboros.Network.PeerSharing - Ouroboros.Network.Tracers Ouroboros.Network.TxSubmission.Inbound Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -213,7 +212,6 @@ library sim-tests-lib base >=4.14 && <4.21, bytestring, cardano-binary, - cardano-prelude, cardano-slotting, cborg, containers, @@ -283,7 +281,6 @@ library sim-tests-lib Test.Ouroboros.Network.PeerSelection.PeerGraph Test.Ouroboros.Network.PeerSelection.PeerMetric Test.Ouroboros.Network.PeerSelection.RootPeersDNS - Test.Ouroboros.Network.PeerState Test.Ouroboros.Network.TxSubmission Test.Ouroboros.Network.Version @@ -339,6 +336,7 @@ test-suite io-tests ouroboros-network, ouroboros-network-api, ouroboros-network-framework, + ouroboros-network-framework:testlib, ouroboros-network-mock, ouroboros-network-protocols, ouroboros-network-protocols:testlib, @@ -381,6 +379,7 @@ executable demo-chain-sync ouroboros-network, ouroboros-network-api, ouroboros-network-framework, + ouroboros-network-framework:testlib, ouroboros-network-mock, ouroboros-network-protocols, random, diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs deleted file mode 100644 index 96c4700cf78..00000000000 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerState.hs +++ /dev/null @@ -1,499 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.Ouroboros.Network.PeerState (tests) where - - -import Control.Exception (ArithException (..), AsyncException (..), - NonTermination (..)) -import Data.Functor (void) -import Data.Map.Strict qualified as Map -import Data.Monoid (First (..)) -import Data.Set qualified as Set -import Text.Printf - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Tracer - -import Data.Semigroup.Action -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Server.ConnectionTable -import Ouroboros.Network.Snocket -import Ouroboros.Network.Subscription.Ip -import Ouroboros.Network.Subscription.PeerState -import Ouroboros.Network.Subscription.Worker - -import Test.QuickCheck hiding (Result) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) - -tests :: TestTree -tests = testGroup "Ouroboros.Network.Subscription.PeerState" - [ testProperty "SuspendDecision semigroup" (prop_SuspendDecisionSemigroup @Int) - , testProperty "Suspend semigroup action on PeerState (up to constructor)" - (prop_SuspendDecisionAction @IO) - , testProperty "worker error handling" prop_subscriptionWorker - ] - - --- --- Generators of 'SuspendDecision' and 'PeerState' --- - -newtype ArbSuspendDecision t = ArbSuspendDecision { - getArbSuspendDecision :: SuspendDecision t - } - deriving (Eq, Show) - -genSuspendDecision :: Gen t - -> Gen (SuspendDecision t) -genSuspendDecision gen = oneof - [ SuspendPeer <$> gen <*> gen - , SuspendConsumer <$> gen - , pure Throw - ] - -genDiffTime :: Gen DiffTime -genDiffTime = fromIntegral @Int <$> arbitrary - -instance Arbitrary t => Arbitrary (ArbSuspendDecision t) where - arbitrary = ArbSuspendDecision <$> genSuspendDecision arbitrary - --- | Subsemigroup formed by 'SuspendPeer' and 'SuspendDecision'. --- -newtype SuspendSubsemigroup t = SuspendSubsemigroup { - getSuspendSubsemigroup :: SuspendDecision t - } - deriving (Eq, Show) - -instance Arbitrary t => Arbitrary (SuspendSubsemigroup t) where - arbitrary = oneof - [ SuspendSubsemigroup <$> (SuspendPeer <$> arbitrary <*> arbitrary) - , SuspendSubsemigroup . SuspendConsumer <$> arbitrary - ] - -newtype ArbPeerState m = ArbPeerState { - getArbPeerState :: PeerState m - } - -instance ( Ord (ThreadId m) - , Show (ThreadId m) - , MonadAsync m - ) => Show (ArbPeerState m) where - show (ArbPeerState p) = "ArbPeerState " ++ show p - --- TODO: it only generates times, not ThreadId's. -instance Arbitrary (ArbPeerState m) where - arbitrary = oneof - [ pure $ ArbPeerState (HotPeer Set.empty Set.empty) - , ArbPeerState . SuspendedConsumer Set.empty . getArbTime <$> arbitrary - , ArbPeerState <$> (SuspendedPeer <$> (getArbTime <$> arbitrary) - <*> (getArbTime <$> arbitrary)) - , pure (ArbPeerState ColdPeer) - ] - --- --- Algebraic properties of 'SuspendDecision' and 'PeerState' --- - -prop_SuspendDecisionSemigroup - :: Ord t - => ArbSuspendDecision t - -> ArbSuspendDecision t - -> ArbSuspendDecision t - -> Bool -prop_SuspendDecisionSemigroup (ArbSuspendDecision a1) - (ArbSuspendDecision a2) - (ArbSuspendDecision a3) = - a1 <> (a2 <> a3) == (a1 <> a2) <> a3 - -prop_SuspendDecisionAction - :: forall m. - Eq (Async m ()) - => Blind (Maybe (ArbPeerState m)) - -> ArbSuspendDecision ArbTime - -> ArbSuspendDecision ArbTime - -> Bool -prop_SuspendDecisionAction - (Blind mps) - (ArbSuspendDecision a1) - (ArbSuspendDecision a2) = - mps' <| (sd1 <> sd2) == (mps' <| sd1 <| sd2) - where - sd1 = getArbTime <$> a1 - sd2 = getArbTime <$> a2 - mps' :: Maybe (PeerState m) - mps' = getArbPeerState <$> mps - --- | Like 'ArbPeerState' but does not generate 'HotPeer' with empty producer --- and consumer sets. --- -newtype ArbValidPeerState m = ArbValidPeerState (PeerState m) - --- TODO -instance Show (ArbValidPeerState t) where - show (ArbValidPeerState _) = "ArbValidPeerState" - -instance Arbitrary (ArbValidPeerState m) where - arbitrary = oneof - [ ArbValidPeerState . SuspendedConsumer Set.empty . getArbTime <$> arbitrary - , ArbValidPeerState <$> (SuspendedPeer <$> (getArbTime <$> arbitrary) - <*> (getArbTime <$> arbitrary)) - , pure (ArbValidPeerState ColdPeer) - ] - -data ArbException where - ArbException - :: Exception err - => err - -> ArbException - -instance Show ArbException where - show (ArbException err) = "ArbException " ++ show err - -data TestException1 = TestException1 - deriving Show - -instance Exception TestException1 - -data TestException2 = TestException2 - deriving Show - -instance Exception TestException2 - -instance Arbitrary ArbException where - arbitrary = oneof - [ pure (ArbException TestException1) - , pure (ArbException TestException2) - -- AsyncException - -- , pure (ArbException StackOverflow) - -- , pure (ArbException HeapOverflow) - -- NonTermination - -- , pure (ArbException NonTermination) - ] - -data ArbErrorPolicies = ArbErrorPolicies [ErrorPolicy] -- application error policy - [ErrorPolicy] -- connection error policy - deriving Show - - -genErrorPolicy :: Gen (SuspendDecision DiffTime) - -> Gen (ErrorPolicy) -genErrorPolicy genCmd = oneof - [ (\cmd -> ErrorPolicy (\(_e :: ArithException) -> Just cmd)) <$> genCmd, - (\cmd -> ErrorPolicy (\(_e :: AsyncException) -> Just cmd)) <$> genCmd, - (\cmd -> ErrorPolicy (\(_e :: NonTermination) -> Just cmd)) <$> genCmd - ] - -instance Arbitrary ArbErrorPolicies where - arbitrary = ArbErrorPolicies <$> listOf genPolicy <*> listOf genPolicy - where - genPolicy = genErrorPolicy (genSuspendDecision genDiffTime) - - shrink (ArbErrorPolicies aps cps) = - let aps' = shrinkList (const []) aps - cps' = shrinkList (const []) cps in - map (\(a,c) -> ArbErrorPolicies a c) $ zip aps' cps' - -data Sock addr = Sock { - remoteAddr :: addr - , localAddr :: addr - } - -data SnocketType where - - -- socket which allocates and connects with out an error, any error can - -- only come from an application - WorkingSnocket :: SnocketType - - -- socket which errors when allocating a socket - AllocateError :: forall e. Exception e - => e - -> SnocketType - - -- socket which errors when attempting a connection - ConnectError :: forall e. Exception e - => e - -> SnocketType - -instance Show SnocketType where - show (AllocateError e) = "AllocateError " ++show e - show (ConnectError e) = "ConnectError " ++show e - show WorkingSnocket = "WorkingSnocket" - -instance Arbitrary SnocketType where - arbitrary = oneof - -- we are not generating 'AllocateErrors', they will not kill the worker, - -- but only the connection thread. - [ (\(ArbException e) -> ConnectError e) <$> arbitrary - , pure WorkingSnocket - ] - --- | 'addrFamily', 'accept' is not needed to run the test suite. --- -mkSnocket :: MonadThrow m - => SnocketType - -> addr - -> addr - -> Snocket m (Sock addr) addr -mkSnocket (AllocateError e) _localAddr _remoteAddr = Snocket { - getLocalAddr = \Sock{localAddr} -> pure localAddr - , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr - , addrFamily = error "not supported" - , open = \_ -> throwIO e - , openToConnect = \_ -> throwIO e - , connect = \_ _ -> pure () - , bind = \_ _ -> pure () - , listen = \_ -> pure () - , accept = \_ -> error "not supported" - , close = \_ -> pure () - } -mkSnocket (ConnectError e) localAddr remoteAddr = Snocket { - getLocalAddr = \Sock{localAddr = addr} -> pure addr - , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr - , addrFamily = error "not supported" - , open = \_ -> pure Sock {remoteAddr, localAddr} - , openToConnect = \_ -> pure Sock {remoteAddr, localAddr} - , connect = \_ _ -> throwIO e - , accept = \_ -> error "not supported" - , bind = \_ _ -> pure () - , listen = \_ -> pure () - , close = \_ -> pure () - } -mkSnocket WorkingSnocket localAddr remoteAddr = Snocket { - getLocalAddr = \Sock{localAddr = addr} -> pure addr - , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr - , addrFamily = error "not supported" - , open = \_ -> pure Sock {remoteAddr, localAddr} - , openToConnect = \_ -> pure Sock {remoteAddr, localAddr} - , connect = \_ _ -> pure () - , bind = \_ _ -> pure () - , listen = \_ -> pure () - , accept = \_ -> error "not supported" - , close = \_ -> pure () - } - -data ArbApp addr = ArbApp (Maybe ArbException) (Sock addr -> IO ()) - -instance Arbitrary (ArbApp addr) where - arbitrary = oneof - [ (\a@(ArbException e) -> ArbApp (Just a) (\_ -> throwIO e)) <$> arbitrary - , pure $ ArbApp Nothing (\_ -> pure ()) - ] - -newtype ArbDiffTime = ArbDiffTime { - getArbDiffTime :: DiffTime - } - deriving Show - deriving Eq - deriving Ord - deriving Num via DiffTime - deriving Fractional via DiffTime - deriving Real via DiffTime - deriving RealFrac via DiffTime - -instance Arbitrary ArbDiffTime where - arbitrary = ArbDiffTime . fromIntegral @Int <$> arbitrary - -instance CoArbitrary ArbDiffTime where - coarbitrary (ArbDiffTime t) = coarbitrary (toRational t) - -instance Function ArbDiffTime where - function = functionRealFrac - -newtype ArbTime = ArbTime { getArbTime :: Time } - deriving Show - deriving Eq - deriving Ord - deriving Num via DiffTime - deriving Fractional via DiffTime - deriving Real via DiffTime - deriving RealFrac via DiffTime - -instance Arbitrary ArbTime where - arbitrary = ArbTime . Time . getArbDiffTime <$> arbitrary - -instance CoArbitrary ArbTime where - coarbitrary (ArbTime (Time t)) = coarbitrary (toRational t) - -instance Function ArbTime where - function = functionRealFrac - -prop_subscriptionWorker - :: SnocketType - -> Int -- local address - -> Int -- remote address - -> ArbValidPeerState IO - -> ArbErrorPolicies - -> (Blind (ArbApp Int)) - -> Property -prop_subscriptionWorker - sockType localAddr remoteAddr (ArbValidPeerState ps) - (ArbErrorPolicies appErrPolicies conErrPolicies) - (Blind (ArbApp merr app)) - = - tabulate "peer states & app errors" [printf "%-20s %s" (peerStateType ps) (exceptionType merr)] $ - ioProperty $ do - doneVar :: StrictTMVar IO () <- newEmptyTMVarIO - tbl <- newConnectionTable - peerStatesVar <- newPeerStatesVar - worker nullTracer - nullTracer - tbl - peerStatesVar - (mkSnocket sockType localAddr remoteAddr) - mempty - WorkerCallbacks { - wcSocketStateChangeTx = \ss s -> do - s' <- socketStateChangeTx ss s - case ss of - CreatedSocket{} -> pure s' - ClosedSocket{} -> tryPutTMVar doneVar () >> pure s', - wcCompleteApplicationTx = completeTx, - wcMainTx = main doneVar - } - WorkerParams { - wpLocalAddresses = LocalAddresses { - laIpv4 = Just localAddr, - laIpv6 = Just localAddr, - laUnix = Nothing - }, - wpSelectAddress = \_ LocalAddresses {laIpv4, laIpv6} -> getFirst (First laIpv4 <> First laIpv6), - wpConnectionAttemptDelay = const Nothing, - wpSubscriptionTarget = - pure $ ipSubscriptionTarget nullTracer peerStatesVar [remoteAddr], - wpValency = 1 - } - (\sock -> app sock - `finally` - (void $ atomically $ tryPutTMVar doneVar ())) - where - completeTx = completeApplicationTx - (ErrorPolicies - appErrPolicies - conErrPolicies) - - main :: StrictTMVar IO () -> Main IO (PeerStates IO Int) Bool - main doneVar s = do - done <- maybe False (const True) <$> tryReadTMVar doneVar - let r = case sockType of - WorkingSnocket -> case merr of - -- TODO: we don't have access to the time when the transition was - -- evaluated. - Nothing -> True - Just (ArbException e) -> transitionSpec remoteAddr ps - (evalErrorPolicies e appErrPolicies) - s - AllocateError _ -> True - ConnectError e -> transitionSpec remoteAddr ps - (evalErrorPolicies e conErrPolicies) - s - if done - then pure r - else if r then retry else pure r - - -- - -- tabulating QuickCheck's cases - -- - - peerStateType HotPeer{} = "HotPeer" - peerStateType SuspendedConsumer{} = "SuspendedConsumer" - peerStateType SuspendedPeer{} = "SuspendedPeer" - peerStateType ColdPeer{} = "ColdPeer" - - exceptionType Nothing = "no-exception" - exceptionType (Just _) = "with-exception" - --- transition spec from a given state to a target states -transitionSpec :: Ord addr - => addr - -> PeerState IO - -> Maybe (SuspendDecision DiffTime) - -> PeerStates IO addr - -> Bool - -transitionSpec _addr _ps0 Nothing ThrowException{} = False - -transitionSpec addr ps0 Nothing (PeerStates peerStates) = - case Map.lookup addr peerStates of - Nothing -> True - Just ps1 -> case (ps0, ps1) of - (ColdPeer, ColdPeer) - -> True - (ColdPeer, HotPeer producers consumers) - -> not (Set.null producers) || not (Set.null consumers) - (ColdPeer, _) - -> False - - -- this transition can happen only if 'producers' are empty - (SuspendedConsumer producers _consT, ColdPeer) - | Set.null producers - -> True - | otherwise - -> False - (SuspendedConsumer _ consT, SuspendedConsumer _ consT') - -> consT == consT' - (SuspendedConsumer _ _consT, HotPeer _ consumers) - -> not $ Set.null consumers - (SuspendedConsumer _ consT, SuspendedPeer _ consT') - -> consT' >= consT - - (SuspendedPeer{}, HotPeer producers consumers) - | Set.null producers && Set.null consumers - -> False - | otherwise - -> True - (SuspendedPeer{}, _) - -> True - - (HotPeer producers consumers, ColdPeer) - | Set.null consumers && Set.null producers - -> True - | otherwise - -> False - (HotPeer{}, HotPeer producers consumers) - | Set.null producers && Set.null consumers - -> False - | otherwise - -> True - (HotPeer{}, SuspendedConsumer{}) - -> True - (HotPeer{}, SuspendedPeer{}) - -> True - -transitionSpec _addr _ps0 (Just Throw) ThrowException{} = True -transitionSpec _addr _ps0 (Just _) ThrowException{} = False - -transitionSpec addr ps0 (Just cmd) (PeerStates peerStates) = - case Map.lookup addr peerStates of - Nothing -> True - Just ps1 -> case (cmd, ps1) of - (SuspendPeer{}, SuspendedPeer{}) - -> True - (SuspendPeer{}, _) - -> False - (SuspendConsumer{}, SuspendedConsumer producers _) - -> getProducers ps0 == producers - (SuspendConsumer{}, SuspendedPeer{}) - -> True - (SuspendConsumer{}, _) - -> False - (Throw, _) - -> True - where - getProducers :: PeerState IO -> Set.Set (Async IO ()) - getProducers (HotPeer producers _) = producers - getProducers (SuspendedConsumer producers _) = producers - getProducers _ = Set.empty diff --git a/ouroboros-network/sim-tests/Main.hs b/ouroboros-network/sim-tests/Main.hs index 2b2959aee2d..af334e017b8 100644 --- a/ouroboros-network/sim-tests/Main.hs +++ b/ouroboros-network/sim-tests/Main.hs @@ -21,7 +21,6 @@ import Test.Ouroboros.Network.PeerSelection.KnownPeers qualified import Test.Ouroboros.Network.PeerSelection.LocalRootPeers qualified import Test.Ouroboros.Network.PeerSelection.PeerMetric qualified import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified -import Test.Ouroboros.Network.PeerState qualified (tests) import Test.Ouroboros.Network.TxSubmission qualified (tests) import Test.Ouroboros.Network.Version qualified (tests) @@ -48,7 +47,6 @@ tests = , Test.Ouroboros.Network.PeerSelection.PeerMetric.tests , Test.Ouroboros.Network.PeerSelection.RootPeersDNS.tests , Test.Ouroboros.Network.PeerSelection.tests - , Test.Ouroboros.Network.PeerState.tests , Test.Ouroboros.Network.Version.tests -- cardano specific logic diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 005e5486044..d6655827e4b 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -19,17 +19,6 @@ module Ouroboros.Network.NodeToClient , nullNetworkConnectTracers , connectTo , connectToWithMux - , NetworkServerTracers (..) - , nullNetworkServerTracers - , NetworkMutableState (..) - , newNetworkMutableState - , newNetworkMutableStateSTM - , cleanNetworkMutableState - , withServer - , NetworkClientSubcriptionTracers - , NetworkSubscriptionTracers (..) - , ClientSubscriptionParams (..) - , ncSubscriptionWorker -- * Null Protocol Peers , chainSyncPeerNull , localStateQueryPeerNull @@ -43,6 +32,7 @@ module Ouroboros.Network.NodeToClient , localSnocket , LocalSocket (..) , LocalAddress (..) + , LocalConnectionId -- * Versions , Versions (..) , versionedNodeToClientProtocols @@ -57,34 +47,19 @@ module Ouroboros.Network.NodeToClient , ConnectionId (..) , MinimalInitiatorContext (..) , ResponderContext (..) - , LocalConnectionId - , ErrorPolicies (..) - , networkErrorPolicies - , nullErrorPolicies - , ErrorPolicy (..) - , ErrorPolicyTrace (..) - , WithAddr (..) - , SuspendDecision (..) , TraceSendRecv (..) , ProtocolLimitFailure , Handshake - , LocalAddresses (..) - , SubscriptionTrace (..) , HandshakeTr ) where -import Cardano.Prelude (FatalError) - import Control.Concurrent.Async qualified as Async -import Control.Exception (ErrorCall, IOException, SomeException) +import Control.Exception (SomeException) import Control.Monad (forever) import Control.Monad.Class.MonadTimer.SI import Codec.CBOR.Term qualified as CBOR import Data.ByteString.Lazy qualified as BL -import Data.Functor (void) -import Data.Functor.Contravariant (contramap) -import Data.Functor.Identity (Identity (..)) import Data.Kind (Type) import Data.Void (Void, absurd) @@ -95,8 +70,6 @@ import Network.TypedProtocol.Stateful.Peer.Client qualified as Stateful import Ouroboros.Network.Context import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) -import Ouroboros.Network.Driver.Simple (DecoderFailure) -import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.NodeToClient.Version @@ -113,11 +86,6 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client as LocalTxSubmission import Ouroboros.Network.Protocol.LocalTxSubmission.Type qualified as LocalTxSubmission import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Client (ClientSubscriptionParams (..)) -import Ouroboros.Network.Subscription.Client qualified as Subscription -import Ouroboros.Network.Subscription.Ip (SubscriptionTrace (..)) -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) -import Ouroboros.Network.Tracers -- The Handshake tracer types are simply terrible. type HandshakeTr ntcAddr ntcVersion = @@ -315,180 +283,6 @@ connectToWithMux snocket tracers versions path k = k - --- | A specialised version of 'Ouroboros.Network.Socket.withServerNode'. --- --- Comments to 'Ouroboros.Network.NodeToNode.withServer' apply here as well. --- -withServer - :: LocalSnocket - -> NetworkServerTracers LocalAddress NodeToClientVersion - -> NetworkMutableState LocalAddress - -> LocalSocket - -> Versions NodeToClientVersion - NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode LocalAddress BL.ByteString IO a b) - -> ErrorPolicies - -> IO Void -withServer sn tracers networkState sd versions errPolicies = - withServerNode' - sn - makeLocalBearer - tracers - networkState - (AcceptedConnectionsLimit maxBound maxBound 0) - sd - nodeToClientHandshakeCodec - noTimeLimitsHandshake - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) - (HandshakeCallbacks acceptableVersion queryVersion) - (SomeResponderApplication <$> versions) - errPolicies - (\_ async -> Async.wait async) - -type NetworkClientSubcriptionTracers - = NetworkSubscriptionTracers Identity LocalAddress NodeToClientVersion - - --- | 'ncSubscriptionWorker' which starts given application versions on each --- established connection. --- -ncSubscriptionWorker - :: forall mode x y. - ( HasInitiator mode ~ True - ) - => LocalSnocket - -> NetworkClientSubcriptionTracers - -> NetworkMutableState LocalAddress - -> ClientSubscriptionParams () - -> Versions - NodeToClientVersion - NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx - mode LocalAddress BL.ByteString IO x y) - -> IO Void -ncSubscriptionWorker - sn - NetworkSubscriptionTracers - { nsSubscriptionTracer - , nsMuxTracer - , nsHandshakeTracer - , nsErrorPolicyTracer - } - networkState - subscriptionParams - versions - = Subscription.clientSubscriptionWorker - sn - (Identity `contramap` nsSubscriptionTracer) - nsErrorPolicyTracer - networkState - subscriptionParams - (void . connectToNode' - sn - makeLocalBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToClientHandshakeCodec, - ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm, - ctaConnectTracers = NetworkConnectTracers nsMuxTracer nsHandshakeTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - versions) - --- | 'ErrorPolicies' for client application. Additional rules can be added by --- means of a 'Semigroup' instance of 'ErrorPolicies'. --- --- This error policies will try to preserve `subscriptionWorker`, e.g. if the --- connect function throws an `IOException` we will suspend it for --- a 'shortDelay', and try to re-connect. --- --- This allows to recover from a situation where a node temporarily shutsdown, --- or running a client application which is subscribed two more than one node --- (possibly over network). --- -networkErrorPolicies :: ErrorPolicies -networkErrorPolicies = ErrorPolicies - { epAppErrorPolicies = [ - -- Handshake client protocol error: we either did not recognise received - -- version or we refused it. This is only for outbound connections to - -- a local node, thus we throw the exception. - ErrorPolicy - $ \(_ :: HandshakeProtocolError NodeToClientVersion) - -> Just ourBug - - -- exception thrown by `runPeerWithLimits` - -- trusted node send too much input - , ErrorPolicy - $ \(_ :: ProtocolLimitFailure) - -> Just ourBug - - -- deserialisation failure of a message from a trusted node - , ErrorPolicy - $ \(_ :: DecoderFailure) - -> Just ourBug - - , ErrorPolicy - $ \e -> case e of - Mx.UnknownMiniProtocol {} -> Just ourBug - Mx.IngressQueueOverRun {} -> Just ourBug - Mx.InitiatorOnly {} -> Just ourBug - Mx.Shutdown {} -> Just ourBug - - -- in case of bearer closed / or IOException we suspend - -- the peer for a short time - -- - -- TODO: the same notes apply as to - -- 'NodeToNode.networkErrorPolicies' - Mx.BearerClosed {} -> Just (SuspendPeer shortDelay shortDelay) - Mx.IOException {} -> Just (SuspendPeer shortDelay shortDelay) - Mx.SDUDecodeError {} -> Just ourBug - Mx.SDUReadTimeout -> Just (SuspendPeer shortDelay shortDelay) - Mx.SDUWriteTimeout -> Just (SuspendPeer shortDelay shortDelay) - - , ErrorPolicy - $ \(e :: Mx.RuntimeError) - -> case e of - Mx.ProtocolAlreadyRunning {} -> Just ourBug - Mx.UnknownProtocolInternalError {} -> Just ourBug - Mx.BlockedOnCompletionVar {} -> Just ourBug - - -- Error thrown by 'IOManager', this is fatal on Windows, and it will - -- never fire on other platofrms. - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - - -- Using 'error' throws. - , ErrorPolicy - $ \(_ :: ErrorCall) - -> Just Throw - - -- Using 'panic' throws. - , ErrorPolicy - $ \(_ :: FatalError) - -> Just Throw - ] - , epConErrorPolicies = [ - -- If an 'IOException' is thrown by the 'connect' call we suspend the - -- peer for 'shortDelay' and we will try to re-connect to it after that - -- period. - ErrorPolicy $ \(_ :: IOException) -> Just $ - SuspendPeer shortDelay shortDelay - - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - ] - } - where - ourBug :: SuspendDecision DiffTime - ourBug = Throw - - shortDelay :: DiffTime - shortDelay = 20 -- seconds - type LocalConnectionId = ConnectionId LocalAddress -- diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 39a4b48d3f7..2628a4d4b5a 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -28,32 +28,11 @@ module Ouroboros.Network.NodeToNode , NetworkConnectTracers (..) , nullNetworkConnectTracers , connectTo - , NetworkServerTracers (..) - , nullNetworkServerTracers - , NetworkMutableState (..) , AcceptedConnectionsLimit (..) - , newNetworkMutableState - , newNetworkMutableStateSTM - , cleanNetworkMutableState - , withServer -- * P2P Governor , PeerAdvertise (..) , PeerSelectionTargets (..) -- * Subscription Workers - -- ** IP subscription worker - , IPSubscriptionTarget (..) - , NetworkIPSubscriptionTracers - , NetworkSubscriptionTracers (..) - , nullNetworkSubscriptionTracers - , SubscriptionParams (..) - , IPSubscriptionParams - , ipSubscriptionWorker - -- ** DNS subscription worker - , DnsSubscriptionTarget (..) - , DnsSubscriptionParams - , NetworkDNSSubscriptionTracers (..) - , nullNetworkDNSSubscriptionTracers - , dnsSubscriptionWorker -- ** Versions , Versions (..) , DiffusionMode (..) @@ -77,26 +56,12 @@ module Ouroboros.Network.NodeToNode , NumTxIdsToAck (..) , ProtocolLimitFailure , Handshake - , LocalAddresses (..) , Socket -- ** Exceptions , ExceptionInHandler (..) - -- ** Error Policies and Peer state - , ErrorPolicies (..) - , remoteNetworkErrorPolicy - , localNetworkErrorPolicy - , nullErrorPolicies - , ErrorPolicy (..) - , SuspendDecision (..) -- ** Traces , AcceptConnectionsPolicyTrace (..) , TraceSendRecv (..) - , SubscriptionTrace (..) - , DnsTrace (..) - , ErrorPolicyTrace (..) - , WithIPList (..) - , WithDomainName (..) - , WithAddr (..) , HandshakeTr -- * For Consensus ThreadNet Tests , chainSyncMiniProtocolNum @@ -106,29 +71,20 @@ module Ouroboros.Network.NodeToNode , peerSharingMiniProtocolNum ) where -import Control.Concurrent.Async qualified as Async -import Control.Exception (IOException, SomeException) -import Control.Monad.Class.MonadTime.SI (DiffTime) +import Control.Exception (SomeException) -import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR import Data.ByteString.Lazy qualified as BL -import Data.Functor (void) -import Data.Void (Void) import Data.Word import Network.Mux qualified as Mx import Network.Socket (Socket, StructLinger (..)) import Network.Socket qualified as Socket -import Ouroboros.Network.BlockFetch.Client (BlockFetchProtocolFailure) import Ouroboros.Network.ConnectionManager.Types (ExceptionInHandler (..)) import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage (ControlMessage (..)) import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) -import Ouroboros.Network.Driver.Simple (DecoderFailure) -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.NodeToNode.Version import Ouroboros.Network.PeerSelection.Governor.Types @@ -139,20 +95,9 @@ import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version hiding (Accept) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..)) +import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Dns (DnsSubscriptionParams, - DnsSubscriptionTarget (..), DnsTrace (..), WithDomainName (..)) -import Ouroboros.Network.Subscription.Dns qualified as Subscription -import Ouroboros.Network.Subscription.Ip (IPSubscriptionParams, - IPSubscriptionTarget (..), SubscriptionParams (..), - SubscriptionTrace (..), WithIPList (..)) -import Ouroboros.Network.Subscription.Ip qualified as Subscription -import Ouroboros.Network.Subscription.Worker (LocalAddresses (..), - SubscriberError) -import Ouroboros.Network.Tracers -import Ouroboros.Network.TxSubmission.Inbound qualified as TxInbound -import Ouroboros.Network.TxSubmission.Outbound qualified as TxOutbound import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) @@ -476,283 +421,6 @@ connectTo sn tr = sl_linger = 0 }) --- | A specialised version of @'Ouroboros.Network.Socket.withServerNode'@. --- It forks a thread which runs an accept loop (server thread): --- --- * when the server thread throws an exception the main thread rethrows --- it (by 'Async.wait') --- * when an async exception is thrown to kill the main thread the server thread --- will be cancelled as well (by 'withAsync') --- -withServer - :: SocketSnocket - -> NetworkServerTracers Socket.SockAddr NodeToNodeVersion - -> NetworkMutableState Socket.SockAddr - -> AcceptedConnectionsLimit - -> Socket.Socket - -- ^ a configured socket to be used be the server. The server will call - -- `bind` and `listen` methods but it will not set any socket or tcp options - -- on it. - -> Versions NodeToNodeVersion - NodeToNodeVersionData - (OuroborosApplicationWithMinimalCtx - Mx.ResponderMode Socket.SockAddr BL.ByteString IO a b) - -> ErrorPolicies - -> IO Void -withServer sn tracers networkState acceptedConnectionsLimit sd versions errPolicies = - withServerNode' - sn - makeSocketBearer - tracers - networkState - acceptedConnectionsLimit - sd - nodeToNodeHandshakeCodec - timeLimitsHandshake - (cborTermVersionDataCodec nodeToNodeCodecCBORTerm) - (HandshakeCallbacks acceptableVersion queryVersion) - (SomeResponderApplication <$> versions) - errPolicies - (\_ async -> Async.wait async) - - --- | 'ipSubscriptionWorker' which starts given application versions on each --- established connection. --- -ipSubscriptionWorker - :: forall mode x y. - ( HasInitiator mode ~ True ) - => SocketSnocket - -> NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeVersion - -> NetworkMutableState Socket.SockAddr - -> IPSubscriptionParams () - -> Versions - NodeToNodeVersion - NodeToNodeVersionData - (OuroborosApplicationWithMinimalCtx - mode Socket.SockAddr BL.ByteString IO x y) - -> IO Void -ipSubscriptionWorker - sn - NetworkSubscriptionTracers - { nsSubscriptionTracer - , nsMuxTracer - , nsHandshakeTracer - , nsErrorPolicyTracer - } - networkState - subscriptionParams - versions - = Subscription.ipSubscriptionWorker - sn - nsSubscriptionTracer - nsErrorPolicyTracer - networkState - subscriptionParams - (void . connectToNode' - sn - makeSocketBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToNodeHandshakeCodec, - ctaHandshakeTimeLimits = timeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, - ctaConnectTracers = NetworkConnectTracers nsMuxTracer nsHandshakeTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - versions) - - --- | 'dnsSubscriptionWorker' which starts given application versions on each --- established connection. --- -dnsSubscriptionWorker - :: forall mode x y. - ( HasInitiator mode ~ True ) - => SocketSnocket - -> NetworkDNSSubscriptionTracers NodeToNodeVersion Socket.SockAddr - -> NetworkMutableState Socket.SockAddr - -> DnsSubscriptionParams () - -> Versions - NodeToNodeVersion - NodeToNodeVersionData - (OuroborosApplicationWithMinimalCtx - mode Socket.SockAddr BL.ByteString IO x y) - -> IO Void -dnsSubscriptionWorker - sn - NetworkDNSSubscriptionTracers - { ndstSubscriptionTracer - , ndstDnsTracer - , ndstMuxTracer - , ndstHandshakeTracer - , ndstErrorPolicyTracer - } - networkState - subscriptionParams - versions = - Subscription.dnsSubscriptionWorker - sn - ndstSubscriptionTracer - ndstDnsTracer - ndstErrorPolicyTracer - networkState - subscriptionParams - (void . connectToNode' - sn - makeSocketBearer - ConnectToArgs { - ctaHandshakeCodec = nodeToNodeHandshakeCodec, - ctaHandshakeTimeLimits = timeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, - ctaConnectTracers = NetworkConnectTracers ndstMuxTracer ndstHandshakeTracer, - ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion - } - versions) - - --- | A minimal error policy for remote peers, which only handles exceptions --- raised by `ouroboros-network`. --- -remoteNetworkErrorPolicy :: ErrorPolicies -remoteNetworkErrorPolicy = ErrorPolicies { - epAppErrorPolicies = [ - -- Handshake client protocol error: we either did not recognise received - -- version or we refused it. This is only for outbound connections, - -- thus we suspend the consumer. - ErrorPolicy - $ \(_ :: HandshakeProtocolError NodeToNodeVersion) - -> Just misconfiguredPeer - - -- deserialisation failure; this means that the remote peer is either - -- buggy, adversarial, or the connection return garbage. In the last - -- case it's also good to shutdown both the consumer and the - -- producer, as it's likely that the other side of the connection - -- will return garbage as well. - , ErrorPolicy - $ \(_ :: DecoderFailure) - -> Just theyBuggyOrEvil - - , ErrorPolicy - $ \(msg :: ProtocolLimitFailure) - -> case msg of - ExceededSizeLimit{} -> Just theyBuggyOrEvil - ExceededTimeLimit{} -> Just (SuspendConsumer shortDelay) - - -- the connection was unexpectedly closed, we suspend the peer for - -- a 'shortDelay' - , ErrorPolicy - $ \e -> case e of - Mx.UnknownMiniProtocol {} -> Just theyBuggyOrEvil - Mx.IngressQueueOverRun {} -> Just theyBuggyOrEvil - Mx.InitiatorOnly {} -> Just theyBuggyOrEvil - - -- in case of bearer closed / or IOException we suspend - -- the peer for a short time - -- - -- TODO: an exponential backoff would be nicer than a fixed 20s - -- TODO: right now we cannot suspend just the - -- 'responder'. If a 'responder' throws 'MuxError' we - -- might not want to shutdown the consumer (which is - -- using different connection), as we do below: - Mx.BearerClosed {} -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.IOException {} -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.SDUDecodeError {} -> Just theyBuggyOrEvil - Mx.SDUReadTimeout -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.SDUWriteTimeout -> Just (SuspendPeer veryShortDelay shortDelay) - Mx.Shutdown {} -> Just (SuspendPeer veryShortDelay shortDelay) - - , ErrorPolicy - $ \(e :: Mx.RuntimeError) - -> case e of - Mx.ProtocolAlreadyRunning {} -> Just (SuspendPeer shortDelay shortDelay) - Mx.UnknownProtocolInternalError {} -> Just Throw - Mx.BlockedOnCompletionVar {} -> Just (SuspendPeer shortDelay shortDelay) - - -- Error policy for TxSubmission protocol: outbound side (client role) - , ErrorPolicy - $ \(_ :: TxOutbound.TxSubmissionProtocolError) - -> Just theyBuggyOrEvil - - -- Error policy for TxSubmission protocol: inbound side (server role) - , ErrorPolicy - $ \(_ :: TxInbound.TxSubmissionProtocolError) - -> Just theyBuggyOrEvil - - -- Error policy for BlockFetch protocol: consumer side (client role) - , ErrorPolicy - $ \(_ :: BlockFetchProtocolFailure) - -> Just theyBuggyOrEvil - - -- Error thrown by 'IOManager', this is fatal on Windows, and it will - -- never fire on other platforms. - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - ], - - -- Exception raised during connect; suspend connecting to that peer for - -- a 'shortDelay' - epConErrorPolicies = [ - ErrorPolicy $ \(_ :: IOException) -> Just $ - SuspendConsumer shortDelay - - , ErrorPolicy - $ \(_ :: IOManagerError) - -> Just Throw - , ErrorPolicy - -- Multiple connection attempts are run in parallel and the last to - -- finish are cancelled. There may be nothing wrong with the peer, - -- it could just be slow to respond. - $ \(_ :: SubscriberError) - -> Just (SuspendConsumer veryShortDelay) - ] - } - where - theyBuggyOrEvil :: SuspendDecision DiffTime - theyBuggyOrEvil = SuspendPeer defaultDelay defaultDelay - - misconfiguredPeer :: SuspendDecision DiffTime - misconfiguredPeer = SuspendConsumer defaultDelay - - defaultDelay :: DiffTime - defaultDelay = 200 -- seconds - - shortDelay :: DiffTime - shortDelay = 20 -- seconds - - veryShortDelay :: DiffTime - veryShortDelay = 1 -- seconds - --- | Error policy for local clients. This is equivalent to --- 'nullErrorPolicies', but explicit in the errors which can be caught. --- --- We are very permissive here, and very strict in the --- `NodeToClient.networkErrorPolicy`. After any failure the client will be --- killed and not penalised by this policy. This allows to restart the local --- client without a delay. --- -localNetworkErrorPolicy :: ErrorPolicies -localNetworkErrorPolicy = ErrorPolicies { - epAppErrorPolicies = [ - -- exception thrown by `runPeerWithLimits` - ErrorPolicy - $ \(_ :: ProtocolLimitFailure) - -> Nothing - - -- deserialisation failure - , ErrorPolicy - $ \(_ :: CBOR.DeserialiseFailure) -> Nothing - - -- the connection was unexpectedly closed, we suspend the peer for - -- a 'shortDelay' - , ErrorPolicy - $ \(_ :: Mx.Error) -> Nothing - ], - - -- The node never connects to a local client - epConErrorPolicies = [] - } - type RemoteAddress = Socket.SockAddr instance ShowProxy RemoteAddress where diff --git a/ouroboros-network/src/Ouroboros/Network/Tracers.hs b/ouroboros-network/src/Ouroboros/Network/Tracers.hs deleted file mode 100644 index 6c1b0c73cb2..00000000000 --- a/ouroboros-network/src/Ouroboros/Network/Tracers.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Ouroboros.Network.Tracers - ( NetworkSubscriptionTracers (..) - , NetworkIPSubscriptionTracers - , nullNetworkSubscriptionTracers - , NetworkDNSSubscriptionTracers (..) - , nullNetworkDNSSubscriptionTracers - ) where - -import Codec.CBOR.Term qualified as CBOR -import Control.Tracer (Tracer, nullTracer) - -import Network.Mux.Trace qualified as Mx - -import Ouroboros.Network.Driver (TraceSendRecv) -import Ouroboros.Network.ErrorPolicy -import Ouroboros.Network.Protocol.Handshake.Type -import Ouroboros.Network.Socket (ConnectionId) -import Ouroboros.Network.Subscription.Dns -import Ouroboros.Network.Subscription.Ip - --- | IP subscription tracers. --- -data NetworkSubscriptionTracers withIPList addr vNumber = NetworkSubscriptionTracers { - nsMuxTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace), - -- ^ low level mux-network tracer, which logs mux sdu (send and received) - -- and other low level multiplexing events. - nsHandshakeTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) - (TraceSendRecv (Handshake vNumber CBOR.Term))), - -- ^ handshake protocol tracer; it is important for analysing version - -- negotation mismatches. - nsErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), - -- ^ error policy tracer; must not be 'nullTracer', otherwise all the - -- exceptions which are not matched by any error policy will be caught - -- and not logged or rethrown. - nsSubscriptionTracer :: Tracer IO (withIPList (SubscriptionTrace addr)) - -- ^ subscription tracers; it is infrequent it should not be 'nullTracer' - -- by default. - } - -type NetworkIPSubscriptionTracers addr vNumber = - NetworkSubscriptionTracers WithIPList addr vNumber - -nullNetworkSubscriptionTracers :: NetworkSubscriptionTracers withIPList addr vNumber -nullNetworkSubscriptionTracers = NetworkSubscriptionTracers { - nsMuxTracer = nullTracer, - nsHandshakeTracer = nullTracer, - nsErrorPolicyTracer = nullTracer, - nsSubscriptionTracer = nullTracer - } - --- | DNS subscription tracers. --- -data NetworkDNSSubscriptionTracers vNumber addr = NetworkDNSSubscriptionTracers { - ndstMuxTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) Mx.Trace), - -- ^ low level mux-network tracer, which logs mux sdu (send and received) - -- and other low level multiplexing events. - ndstHandshakeTracer :: Tracer IO (Mx.WithBearer (ConnectionId addr) - (TraceSendRecv (Handshake vNumber CBOR.Term))), - -- ^ handshake protocol tracer; it is important for analysing version - -- negotation mismatches. - ndstErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), - -- ^ error policy tracer; must not be 'nullTracer', otherwise all the - -- exceptions which are not matched by any error policy will be caught - -- and not logged or rethrown. - ndstSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace addr)), - -- ^ subscription tracer; it is infrequent it should not be 'nullTracer' - -- by default. - ndstDnsTracer :: Tracer IO (WithDomainName DnsTrace) - -- ^ dns resolver tracer; it is infrequent it should not be 'nullTracer' - -- by default. - - } - -nullNetworkDNSSubscriptionTracers :: NetworkDNSSubscriptionTracers vNumber peerid -nullNetworkDNSSubscriptionTracers = NetworkDNSSubscriptionTracers { - ndstMuxTracer = nullTracer, - ndstHandshakeTracer = nullTracer, - ndstErrorPolicyTracer = nullTracer, - ndstSubscriptionTracer = nullTracer, - ndstDnsTracer = nullTracer - } From f75b35c9c7782bdd129b7778f489c49d5522ed46 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 4 Nov 2024 09:57:02 +0100 Subject: [PATCH 4/6] ouroboros-network-framework: renamed Ourboros.Network.Server2 module --- .../demo/connection-manager.hs | 2 +- ouroboros-network-framework/io-tests/Main.hs | 4 ++-- .../Ouroboros/Network/{Server2 => Server}/IO.hs | 4 ++-- .../ouroboros-network-framework.cabal | 6 +++--- ouroboros-network-framework/sim-tests/Main.hs | 4 ++-- .../Test/Ouroboros/Network/ConnectionManager.hs | 2 +- .../Ouroboros/Network/{Server2 => Server}/Sim.hs | 8 ++++---- .../Ouroboros/Network/{Server2.hs => Server.hs} | 2 +- .../Network/ConnectionManager/Experiments.hs | 4 ++-- .../Ouroboros/Network/InboundGovernor/Utils.hs | 4 ++-- .../Test/Ouroboros/Network/Data/AbsBearerInfo.hs | 4 ++-- .../Ouroboros/Network/Diffusion/Testnet/Cardano.hs | 14 +++++++------- .../Diffusion/Testnet/Cardano/Simulation.hs | 2 +- .../src/Ouroboros/Network/Diffusion.hs | 2 +- .../src/Ouroboros/Network/Diffusion/Types.hs | 2 +- 15 files changed, 32 insertions(+), 32 deletions(-) rename ouroboros-network-framework/io-tests/Test/Ouroboros/Network/{Server2 => Server}/IO.hs (97%) rename ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/{Server2 => Server}/Sim.hs (99%) rename ouroboros-network-framework/src/Ouroboros/Network/{Server2.hs => Server.hs} (99%) diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 4c891308b4f..4ecc64bd474 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -74,8 +74,8 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version (Acceptable (..), Queryable (..)) import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, socketSnocket) import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Socket () diff --git a/ouroboros-network-framework/io-tests/Main.hs b/ouroboros-network-framework/io-tests/Main.hs index aa53420f74e..e1c1608436a 100644 --- a/ouroboros-network-framework/io-tests/Main.hs +++ b/ouroboros-network-framework/io-tests/Main.hs @@ -5,7 +5,7 @@ import Test.Tasty import Test.Ouroboros.Network.Driver qualified as Driver import Test.Ouroboros.Network.RawBearer qualified as RawBearer -import Test.Ouroboros.Network.Server2.IO qualified as Server2 +import Test.Ouroboros.Network.Server.IO qualified as Server import Test.Ouroboros.Network.Socket qualified as Socket main :: IO () @@ -15,7 +15,7 @@ tests :: TestTree tests = testGroup "ouroboros-network-framework:io-tests" [ Driver.tests - , Server2.tests + , Server.tests , Socket.tests , RawBearer.tests ] diff --git a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server2/IO.hs b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server/IO.hs similarity index 97% rename from ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server2/IO.hs rename to ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server/IO.hs index 83f1d6a8937..cbc1fe68674 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server2/IO.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Server/IO.hs @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -Wno-x-partial #-} #endif -module Test.Ouroboros.Network.Server2.IO (tests) where +module Test.Ouroboros.Network.Server.IO (tests) where import Control.Monad.Class.MonadThrow import System.Random (mkStdGen) @@ -34,7 +34,7 @@ import Test.Ouroboros.Network.Orphans () tests :: TestTree tests = testGroup "Ouroboros.Network" - [ testGroup "Server2" + [ testGroup "Server" [ testProperty "unidirectional IO" prop_unidirectional_IO , testProperty "bidirectional IO" prop_bidirectional_IO ] diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 71870d9011c..4da1d117ca4 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -54,9 +54,9 @@ library Ouroboros.Network.Protocol.Handshake.Version Ouroboros.Network.RawBearer Ouroboros.Network.RethrowPolicy + Ouroboros.Network.Server Ouroboros.Network.Server.ConnectionTable Ouroboros.Network.Server.RateLimiting - Ouroboros.Network.Server2 Ouroboros.Network.Snocket Ouroboros.Network.Socket Simulation.Network.Snocket @@ -162,7 +162,7 @@ test-suite sim-tests Test.Ouroboros.Network.ConnectionManager Test.Ouroboros.Network.RateLimiting Test.Ouroboros.Network.RawBearer - Test.Ouroboros.Network.Server2.Sim + Test.Ouroboros.Network.Server.Sim Test.Ouroboros.Network.Socket Test.Simulation.Network.Snocket @@ -231,7 +231,7 @@ test-suite io-tests other-modules: Test.Ouroboros.Network.Driver Test.Ouroboros.Network.RawBearer - Test.Ouroboros.Network.Server2.IO + Test.Ouroboros.Network.Server.IO Test.Ouroboros.Network.Socket build-depends: diff --git a/ouroboros-network-framework/sim-tests/Main.hs b/ouroboros-network-framework/sim-tests/Main.hs index 29a51dbf4ed..ab9d05de52b 100644 --- a/ouroboros-network-framework/sim-tests/Main.hs +++ b/ouroboros-network-framework/sim-tests/Main.hs @@ -5,7 +5,7 @@ import Test.Tasty import Test.Ouroboros.Network.ConnectionManager qualified as ConnectionManager import Test.Ouroboros.Network.RateLimiting qualified as RateLimiting -import Test.Ouroboros.Network.Server2.Sim qualified as Server2 +import Test.Ouroboros.Network.Server.Sim qualified as Server import Test.Simulation.Network.Snocket qualified as Snocket main :: IO () @@ -15,7 +15,7 @@ tests :: TestTree tests = testGroup "ouroboros-network-framework:sim-tests" [ ConnectionManager.tests - , Server2.tests + , Server.tests , RateLimiting.tests , Snocket.tests ] diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs index 9ffc52a5eee..83d36cba17c 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -80,7 +80,7 @@ tests :: TestTree tests = testGroup "Ouroboros.Network.ConnectionManager" [ -- generators, shrinkers properties - -- TODO: replace these tests with 'Test.Ouroboros.Network.Server2' simulation. + -- TODO: replace these tests with 'Test.Ouroboros.Network.Server' simulation. testProperty "overwritten" unit_overwritten , testProperty "timeoutExpired" unit_timeoutExpired ] diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs similarity index 99% rename from ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs rename to ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index a0e2a206d04..80369565196 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -19,7 +19,7 @@ -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} -module Test.Ouroboros.Network.Server2.Sim (tests) where +module Test.Ouroboros.Network.Server.Sim (tests) where import Control.Applicative (Alternative ((<|>))) import Control.Concurrent.Class.MonadSTM qualified as LazySTM @@ -86,9 +86,9 @@ import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Protocol.Handshake.Codec (noTimeLimitsHandshake, timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Unversioned +import Ouroboros.Network.Server (RemoteTransitionTrace) +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 (RemoteTransitionTrace) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) import Ouroboros.Network.Snocket qualified as Snocket @@ -137,7 +137,7 @@ tests = , testProperty "matured peers" prop_inbound_governor_maturedPeers , testProperty "timeouts enforced" prop_timeouts_enforced ] - , testGroup "Server2" + , testGroup "Server" [ testProperty "unidirectional Sim" prop_unidirectional_Sim , testProperty "bidirectional Sim" prop_bidirectional_Sim , testProperty "never above hardlimit" prop_never_above_hardlimit diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs similarity index 99% rename from ouroboros-network-framework/src/Ouroboros/Network/Server2.hs rename to ouroboros-network-framework/src/Ouroboros/Network/Server.hs index 662421f7429..dd4e4a66308 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs @@ -15,7 +15,7 @@ -- -- This module should be imported qualified. -- -module Ouroboros.Network.Server2 +module Ouroboros.Network.Server ( Arguments (..) -- * Run server , with 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 71b4904527c..94e7857e1f6 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -93,9 +93,9 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version (Acceptable (..), Queryable (..)) import Ouroboros.Network.RethrowPolicy +import Ouroboros.Network.Server (RemoteTransitionTrace) +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Server2 (RemoteTransitionTrace) -import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Snocket qualified as Snocket diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs index 74bf45c8fc8..c7204ce774d 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs @@ -11,8 +11,8 @@ import Test.QuickCheck.Monoids import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor (RemoteSt (..)) import Ouroboros.Network.InboundGovernor qualified as IG -import Ouroboros.Network.Server2 (RemoteTransition) -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server (RemoteTransition) +import Ouroboros.Network.Server qualified as Server -- | Pattern synonym which matches either 'RemoteHotEst' or 'RemoteWarmSt'. diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs index 6e59f438593..01f0fd621e9 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/AbsBearerInfo.hs @@ -132,14 +132,14 @@ instance Arbitrary AbsIOError where , connectionAbortedError ] where - -- `ECONNABORTED` error which appears in `Ouroboros.Network.Server2` + -- `ECONNABORTED` error which appears in `Ouroboros.Network.Server` connectionAbortedError :: IOError connectionAbortedError = IOError { ioe_handle = Nothing , ioe_type = OtherError , ioe_location = "Ouroboros.Network.Snocket.Sim.accept" -- Note: this matches the `iseCONNABORTED` on Windows, see - -- 'Ouroboros.Network.Server2` + -- 'Ouroboros.Network.Server` , ioe_description = "Software caused connection abort (WSAECONNABORTED)" , ioe_errno = Just (case eCONNABORTED of Errno errno -> errno) , ioe_filename = Nothing diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index 09d2bb26aa7..d5937639aa0 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -85,7 +85,7 @@ import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.PeerSelection.Types import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server qualified as Server import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.ConnectionManager.Utils @@ -3204,7 +3204,7 @@ prop_diffusion_target_active_local_above ioSimTrace traceNumber = -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transitions' +-- 'Test.Ouroboros.Network.Server.prop_connection_manager_valid_transitions' -- but for running on Diffusion. This means it has to have in consideration -- that the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -3292,7 +3292,7 @@ prop_diffusion_cm_valid_transitions ioSimTrace traceNumber = -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transition_order' +-- 'Test.Ouroboros.Network.Server.prop_connection_manager_valid_transition_order' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -3353,7 +3353,7 @@ prop_diffusion_cm_valid_transition_order_iosim_por ioSimTrace traceNumber = . groupConns id abstractStateIsFinalTransitionTVarTracing -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_connection_manager_valid_transition_order' +-- 'Test.Ouroboros.Network.Server.prop_connection_manager_valid_transition_order' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -4223,7 +4223,7 @@ prop_splitWith f as = foldr (++) [] (splitWith f as) === as -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_inbound_governor_valid_transitions' +-- 'Test.Ouroboros.Network.Server.prop_inbound_governor_valid_transitions' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -4281,7 +4281,7 @@ prop_diffusion_ig_valid_transitions ioSimTrace traceNumber = $ remoteTransitionTraceEvents -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_inbound_governor_valid_transition_order' +-- 'Test.Ouroboros.Network.Server.prop_inbound_governor_valid_transition_order' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. @@ -4334,7 +4334,7 @@ prop_diffusion_ig_valid_transition_order ioSimTrace traceNumber = $ remoteTransitionTraceEvents -- | A variant of ouroboros-network-framework --- 'Test.Ouroboros.Network.Server2.prop_timeouts_enforced' +-- 'Test.Ouroboros.Network.Server.prop_timeouts_enforced' -- but for running on Diffusion. This means it has to have in consideration the -- the logs for all nodes running will all appear in the trace and the test -- property should only be valid while a given node is up and running. diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 4975a39c8a9..2897ab21a87 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -136,7 +136,7 @@ import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive, import Ouroboros.Network.Protocol.Limits (shortWait, smallByteLimit) import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, timeLimitsPeerSharing) -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace, diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 9ca67d80bf1..08a45052405 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -98,7 +98,7 @@ import Ouroboros.Network.Protocol.Handshake import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Version import Ouroboros.Network.RethrowPolicy -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (LocalAddress, LocalSocket (..), localSocketFileDescriptor, makeLocalBearer, makeSocketBearer) import Ouroboros.Network.Snocket qualified as Snocket diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs index 14e9494066b..da67d15c93e 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -65,7 +65,7 @@ import Ouroboros.Network.InboundGovernor qualified as IG import Ouroboros.Network.Mux qualified as Mx import Ouroboros.Network.Protocol.Handshake (HandshakeArguments, Versions) import Ouroboros.Network.RethrowPolicy -import Ouroboros.Network.Server2 qualified as Server +import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Snocket (FileDescriptor, Snocket) import Ouroboros.Network.Socket (SystemdSocketTracer) From c0f201880fc7c102038409f1fd0dd96a719af71b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 13 Feb 2025 11:18:05 +0100 Subject: [PATCH 5/6] ouroboros-newtwork-framework: added Ouroboros.Network.Server.Simple --- ouroboros-network-framework/CHANGELOG.md | 3 ++- ouroboros-network-framework/demo/ping-pong.hs | 6 +++--- .../io-tests/Test/Ouroboros/Network/Socket.hs | 4 ++-- .../ouroboros-network-framework.cabal | 3 +-- .../sim-tests/Test/Ouroboros/Network/Socket.hs | 6 +++--- .../Server.hs => src/Ouroboros/Network/Server/Simple.hs} | 5 +++-- ouroboros-network/demo/chain-sync.hs | 6 +++--- ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs | 4 ++-- ouroboros-network/ouroboros-network.cabal | 2 -- 9 files changed, 19 insertions(+), 20 deletions(-) rename ouroboros-network-framework/{testlib/Test/Ouroboros/Network/Server.hs => src/Ouroboros/Network/Server/Simple.hs} (94%) diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index f86e39f60f3..3dddbaef878 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -9,12 +9,13 @@ * `Ouroboros.Network.ErrorPolicy` removed. * APIs removed from `Ouroboros.Network.Socket`: * `NetworkMutableState` & friends, - * `withServerNode`, + * `withServerNode` (see below for a replacement), * `NetworkServerTracers`, * `fromSnocket`, * `beginConnection` * `Ouroboros.Network.Server.Socket` replaced with a simpler server implementation in `Test.Ouroboros.Network.Server` (in `ouroboros-network:testlib` component). +* Added `Ouroboros.Network.Server.Simple.with` to run a simple server as a replacement for `Ouroboros.Network.Socket.withServerNode`. ### Non-breaking changes diff --git a/ouroboros-network-framework/demo/ping-pong.hs b/ouroboros-network-framework/demo/ping-pong.hs index 73ec28bc39f..4ea1834cbac 100644 --- a/ouroboros-network-framework/demo/ping-pong.hs +++ b/ouroboros-network-framework/demo/ping-pong.hs @@ -38,7 +38,7 @@ import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version -import Test.Ouroboros.Network.Server qualified as Test.Server +import Ouroboros.Network.Server.Simple qualified as Server import Network.TypedProtocol.PingPong.Client as PingPong import Network.TypedProtocol.PingPong.Codec.CBOR as PingPong @@ -158,7 +158,7 @@ clientPingPong pipelined = serverPingPong :: IO Void serverPingPong = withIOManager $ \iomgr -> do - Test.Server.with + Server.with (Snocket.localSnocket iomgr) makeLocalBearer mempty @@ -252,7 +252,7 @@ clientPingPong2 = serverPingPong2 :: IO Void serverPingPong2 = withIOManager $ \iomgr -> do - Test.Server.with + Server.with (Snocket.localSnocket iomgr) makeLocalBearer mempty 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 f70bd60ab7a..6a9a8a1259d 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -54,6 +54,7 @@ import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -- TODO: remove Mx prefixes import Ouroboros.Network.Mux +import Ouroboros.Network.Server.Simple qualified as Server.Simple import Network.Mux qualified as Mx import Network.Mux.Bearer qualified as Mx @@ -66,7 +67,6 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version import Test.Ouroboros.Network.Orphans () -import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (DependencyType (..), TestTree, after, testGroup) @@ -239,7 +239,7 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = let snocket = socketSnocket iomgr res <- - Test.Server.with + Server.Simple.with snocket Mx.makeSocketBearer ((. Just) <$> configureSock) diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 4da1d117ca4..2517acf730b 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -57,6 +57,7 @@ library Ouroboros.Network.Server Ouroboros.Network.Server.ConnectionTable Ouroboros.Network.Server.RateLimiting + Ouroboros.Network.Server.Simple Ouroboros.Network.Snocket Ouroboros.Network.Socket Simulation.Network.Snocket @@ -116,7 +117,6 @@ library testlib Test.Ouroboros.Network.InboundGovernor.Utils Test.Ouroboros.Network.Orphans Test.Ouroboros.Network.RawBearer.Utils - Test.Ouroboros.Network.Server other-modules: build-depends: @@ -288,7 +288,6 @@ executable demo-ping-pong network-mux, ouroboros-network-api, ouroboros-network-framework, - ouroboros-network-framework:testlib, typed-protocols-examples, default-language: Haskell2010 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 4e0649a2ebf..b5dac507f79 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs @@ -56,6 +56,7 @@ import Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Socket -- TODO: remove Mx prefixes import Ouroboros.Network.Mux +import Ouroboros.Network.Server.Simple qualified as Server.Simple import Network.Mux qualified as Mx import Network.Mux.Bearer qualified as Mx @@ -69,7 +70,6 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Protocol.Handshake.Version import Test.Ouroboros.Network.Orphans () -import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (DependencyType (..), TestTree, after, testGroup) @@ -246,9 +246,9 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs = bind snocket sock responderAddr listen snocket sock res <- - Test.Server.with + Server.Simple.with snocket - makeSocketBearer + Mx.makeSocketBearer (\fd addr -> configureSock fd (Just addr)) responderAddr HandshakeArguments { diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs similarity index 94% rename from ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs rename to ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs index 9acb95e7477..05dfd839369 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/Server.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs @@ -4,10 +4,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} --- | A simple server implemented for testing purposes +-- | A simple server. The server doesn't control resource usage (e.g. limiting +-- of inbound connections) and thus should only be used in a safe environment. -- -- The module should be imported qualified. -module Test.Ouroboros.Network.Server where +module Ouroboros.Network.Server.Simple where import Control.Applicative (Alternative) import Control.Concurrent.JobPool qualified as JobPool diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index c237335f078..dfe73191fab 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -79,7 +79,7 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientRegistry (..)) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) import Ouroboros.Network.DeltaQ (defaultGSV) -import Test.Ouroboros.Network.Server qualified as Test.Server +import Ouroboros.Network.Server.Simple qualified as Server.Simple data Options = Options { @@ -274,7 +274,7 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of Nothing -> initStdGen Just a -> return (mkStdGen a) - Test.Server.with + Server.Simple.with (localSnocket iocp) makeLocalBearer mempty @@ -548,7 +548,7 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do prng <- case seed of Nothing -> initStdGen Just a -> return (mkStdGen a) - Test.Server.with + Server.Simple.with (localSnocket iocp) makeLocalBearer mempty diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs index 319e6b7eeb5..82d91784bc9 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs @@ -48,11 +48,11 @@ import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, noTimeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, queryVersion) +import Ouroboros.Network.Server.Simple qualified as Server.Simple import Ouroboros.Network.Util.ShowProxy import Test.ChainGenerators (TestBlockChainAndUpdates (..)) import Test.Ouroboros.Network.Serialise -import Test.Ouroboros.Network.Server qualified as Test.Server import Test.QuickCheck import Test.Tasty (TestTree, testGroup) @@ -158,7 +158,7 @@ demo chain0 updates = withIOManager $ \iocp -> do encode decode (encodeTip encode) (decodeTip decode) - Test.Server.with + Server.Simple.with (socketSnocket iocp) makeSocketBearer ((. Just) <$> configureSocket) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 20788fa2688..840db9d2560 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -336,7 +336,6 @@ test-suite io-tests ouroboros-network, ouroboros-network-api, ouroboros-network-framework, - ouroboros-network-framework:testlib, ouroboros-network-mock, ouroboros-network-protocols, ouroboros-network-protocols:testlib, @@ -379,7 +378,6 @@ executable demo-chain-sync ouroboros-network, ouroboros-network-api, ouroboros-network-framework, - ouroboros-network-framework:testlib, ouroboros-network-mock, ouroboros-network-protocols, random, From cbf175fdd1961e69d94cfe58c0f92042934856ff Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 4 Nov 2024 09:57:54 +0100 Subject: [PATCH 6/6] Updated documentation --- scripts/prologue | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/scripts/prologue b/scripts/prologue index 8ebefb791ea..2c0bb13a174 100644 --- a/scripts/prologue +++ b/scripts/prologue @@ -32,8 +32,7 @@ This site contains Haskell documentation of __Ouroboros-Network__ ouroboros protocols, but build a solid foundation for the networking library. Among others, it includes * __[Inbound Governor](ouroboros-network-framework/Ouroboros-Network-InboundGovernor.html)__ - * __[Server P2P](ouroboros-network-framework/Ouroboros-Network-Server2.html)__ - * __[Server NonP2P](ouroboros-network-framework/Ouroboros-Network-Server-Socket.html)__ + * __[Server P2P](ouroboros-network-framework/Ouroboros-Network-Server.html)__ * __[Socket](ouroboros-network-framework/Ouroboros-Network-Socket.html)__ * __[Snocket](ouroboros-network-framework/Ouroboros-Network-Snocket.html)__ * __[Simulated Snocket](ouroboros-network-framework/Simulation-Network-Snocket.html)__