diff --git a/docs/network-spec/connection-manager.tex b/docs/network-spec/connection-manager.tex index ab5c8c25b3e..9b8c7b30161 100644 --- a/docs/network-spec/connection-manager.tex +++ b/docs/network-spec/connection-manager.tex @@ -2100,15 +2100,18 @@ \subsubsection{\RemoteIdle} connection is used (\warm{} or \hot{}) or not (\cold{}) by the outbound side. \subsubsection{\RemoteWarm} -A connection enters \RemoteWarm{} state once any of the mini-protocols starts -to operate. Once all hot mini-protocols start, the state will transition to -\RemoteHot{}. Note that this is slightly different than the notion of a \warm{} -peer, for which all \established{} and \warm{} mini-protocols are active, but -\hot{} ones are idle. +A connection dwells in \RemoteWarm{} if there are strictly only any warm or established +responder protocols running. Note also that an established protocol is one that may run +in both hot and warm states, but cannot be the only type running to maintain hot state +once all proper hot protocols have terminated. In other words, the connection must be +demoted in that case. \subsubsection{\RemoteHot} -A connection enters \RemoteHot{} transition once all hot protocols started, if -any of them terminates the connection will be put in \RemoteWarm{}. +A connection enters \RemoteHot{} state once any hot responder protocol has started. +In particular, if a hot responder is the first to start, the state cycles through \RemoteWarm{} +first. Once all hot responders terminate, the connection will be put in \RemoteWarm{} regardless +of whether there are any warm or established responders left. In the latter case, if there aren't any +other protocols running, the connection will then follow up with further demotion to \RemoteIdle{}. \subsection{Transitions} @@ -2166,11 +2169,10 @@ \subsubsection{\MuxTerminated} termination of the connection, as it can detect this by itself. \subsubsection{\PromotedToHotRemote} -The inbound governor detects when all \hot{} mini-protocols started. In such +The inbound governor detects when any \hot{} mini-protocols have started. In such case a \RemoteWarm{} connection is put in \RemoteHot{} state. \subsubsection{\DemotedToWarmRemote} -Dually to \PromotedToHotRemote{} state transition, as soon as any of the \hot{} -mini-protocols terminates, the connection will transition to \RemoteWarm{} +Dually to \PromotedToHotRemote{} state transition, as soon as all of the \hot{} +mini-protocols terminate, the connection will transition to \RemoteWarm{} state. - diff --git a/network-mux/CHANGELOG.md b/network-mux/CHANGELOG.md index f6fcdea84ba..a0a6df8bc6c 100644 --- a/network-mux/CHANGELOG.md +++ b/network-mux/CHANGELOG.md @@ -3,15 +3,11 @@ ## next release ### Breaking changes -* Bearer writeMany function for vector IO -* An optional read buffer for Bearer -* Polling of the egress queue + +* run, miniProtocolJob, monitor now accept Tracers record + instead of `Tracer m Trace` type. ### Non-breaking changes -* Define msHeaderLength instead of using '8' -* Benchmark for Socket Bearer -* Use ByteString.Builder for the ingress queues -* Signal the kernal that we require at least the full SDU's worth of data ## 0.8.0.1 -- 2025-06-02 @@ -27,6 +23,8 @@ * `MakeBearer` accepts optional `ReadBuffer` * added fields `egressInterval`, `writeMany`, `batchSize` to `Bearer` + * writeMany provides vector IO, egressInterval supports polling of egress queue + for tuning latency vs. network efficiency * `socketAsBearer` additionally takes `ReadBuffer`, egress interval `DiffTime` for egress polling, and batchSize * changed `IngressQueue` type synonym @@ -35,6 +33,10 @@ ### Non-breaking changes * added `makeSocketBearer'`, `ReadBuffer`, `withReadBufferIO` +* Define msHeaderLength instead of using '8' +* Benchmark for Socket Bearer +* Use ByteString.Builder for the ingress queues +* Signal the kernal that we require at least the full SDU's worth of data ## 0.7.0.0 -- 2025-02-25 diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs index aefde5e8432..e905beb4f26 100644 --- a/network-mux/demo/mux-demo.hs +++ b/network-mux/demo/mux-demo.hs @@ -68,6 +68,8 @@ putStrLn_ = BSC.putStrLn . BSC.pack debugTracer :: Show a => Tracer IO a debugTracer = showTracing (Tracer putStrLn_) +nullTracers :: (Applicative m) => Tracers m +nullTracers = Tracers nullTracer nullTracer -- -- Protocols -- @@ -133,7 +135,7 @@ serverWorker bearer = do putStrLn $ "Result: " ++ show result Mx.stop mux - Mx.run nullTracer mux bearer + Mx.run nullTracers mux bearer where ptcls :: [MiniProtocolInfo ResponderMode] ptcls = [ MiniProtocolInfo { @@ -193,7 +195,7 @@ clientWorker bearer n msg = do putStrLn $ "Result: " ++ show result Mx.stop mux - Mx.run nullTracer mux bearer + Mx.run nullTracers mux bearer where ptcls :: [MiniProtocolInfo Mx.InitiatorMode] ptcls = [ MiniProtocolInfo { @@ -208,4 +210,3 @@ echoClient :: Int -> Int -> ByteString -> ReqRespClient ByteString ByteString IO Int echoClient !n 0 _ = SendMsgDone (pure n) echoClient !n m rawmsg = SendMsgReq rawmsg (pure . echoClient (n+1) (m-1)) - diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 26e7d6fd7ff..37f83a20dbc 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -45,6 +45,7 @@ module Network.Mux , traceBearerState , BearerState (..) , Trace (..) + , Tracers (..) , WithBearer (..) ) where @@ -212,11 +213,11 @@ run :: forall m (mode :: Mode). , MonadTimer m , MonadMask m ) - => Tracer m Trace + => Tracers m -> Mux mode m -> Bearer m -> m () -run tracer +run tracers@Tracers { muxTracer = tracer } Mux { muxMiniProtocols, muxControlCmdQueue, muxStatus @@ -238,7 +239,7 @@ run tracer -- Wait for someone to shut us down by calling muxStop or an error. -- Outstanding jobs are shut down Upon completion of withJobPool. withTimeoutSerial $ \timeout -> - monitor tracer + monitor tracers timeout jobpool egressQueue @@ -250,6 +251,7 @@ run tracer -- deadlock of mini-protocol completion action. `catch` \(SomeAsyncException e) -> do atomically $ writeTVar muxStatus (Failed $ toException e) + traceWith tracer $ TraceState Dead throwIO e where muxerJob egressQueue = @@ -272,12 +274,15 @@ miniProtocolJob , MonadThread m , MonadThrow (STM m) ) - => Tracer m Trace + => Tracers m -> EgressQueue m -> MiniProtocolState mode m -> MiniProtocolAction m -> JobPool.Job Group m JobResult -miniProtocolJob tracer egressQueue +miniProtocolJob Tracers { + muxTracer = tracer, + channelTracer } + egressQueue MiniProtocolState { miniProtocolInfo = MiniProtocolInfo { @@ -300,7 +305,7 @@ miniProtocolJob tracer egressQueue labelThisThread (case miniProtocolNum of MiniProtocolNum a -> "prtcl-" ++ show a) w <- newTVarIO BL.empty - let chan = muxChannel tracer egressQueue (Wanton w) + let chan = muxChannel channelTracer egressQueue (Wanton w) miniProtocolNum miniProtocolDirEnum miniProtocolIngressQueue (result, remainder) <- miniProtocolAction chan @@ -390,14 +395,16 @@ monitor :: forall mode m. , Alternative (STM m) , MonadThrow (STM m) ) - => Tracer m Trace + => Tracers m -> TimeoutFn m -> JobPool.JobPool Group m JobResult -> EgressQueue m -> StrictTQueue m (ControlCmd mode m) -> StrictTVar m Status -> m () -monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = +monitor tracers@Tracers { + muxTracer = tracer } + timeout jobpool egressQueue cmdQueue muxStatus = go (MonitorCtx Map.empty Map.empty) where go :: MonitorCtx m mode -> m () @@ -433,9 +440,9 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = go monitorCtx EventJobResult (MiniProtocolException pnum pmode e) -> do - traceWith tracer (TraceState Dead) - traceWith tracer (TraceExceptionExit pnum pmode e) atomically $ writeTVar muxStatus $ Failed e + traceWith tracer (TraceExceptionExit pnum pmode e) + traceWith tracer (TraceState Dead) throwIO e -- These two cover internal and protocol errors. The muxer exception is @@ -447,11 +454,10 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = -- the source of the failure, e.g. specific mini-protocol. If we're -- propagating exceptions, we don't need to log them. EventJobResult (MuxerException e) -> do - traceWith tracer (TraceState Dead) atomically $ writeTVar muxStatus $ Failed e + traceWith tracer (TraceState Dead) throwIO e EventJobResult (DemuxerException e) -> do - traceWith tracer (TraceState Dead) r <- atomically $ do size <- JobPool.readGroupSize jobpool MiniProtocolJob case size of @@ -460,6 +466,7 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = >> return True _ -> writeTVar muxStatus (Failed e) >> return False + traceWith tracer (TraceState Dead) unless r (throwIO e) EventControlCmd (CmdStartProtocolThread @@ -478,14 +485,14 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = Nothing -> JobPool.forkJob jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction Just cap -> JobPool.forkJobOn cap jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction @@ -585,14 +592,14 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = Nothing -> JobPool.forkJob jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction Just cap -> JobPool.forkJobOn cap jobpool $ miniProtocolJob - tracer + tracers egressQueue ptclState ptclAction @@ -654,7 +661,7 @@ muxChannel -> IngressQueue m -> ByteChannel m muxChannel tracer egressQueue want@(Wanton w) mc md q = - Channel { send, recv} + Channel { send, recv } where -- Limit for the message buffer between send and mux thread. perMiniProtocolBufferSize :: Int64 @@ -797,4 +804,3 @@ runMiniProtocol Mux { muxMiniProtocols, muxControlCmdQueue , muxStatus} <|> return (Left $ toException (Shutdown Nothing st)) Failed e -> readTMVar completionVar <|> return (Left $ toException (Shutdown (Just e) st)) - diff --git a/network-mux/src/Network/Mux/Trace.hs b/network-mux/src/Network/Mux/Trace.hs index 7aefacef454..130380ee79e 100644 --- a/network-mux/src/Network/Mux/Trace.hs +++ b/network-mux/src/Network/Mux/Trace.hs @@ -10,6 +10,7 @@ module Network.Mux.Trace ( Error (..) , handleIOException , Trace (..) + , Tracers (..) , BearerState (..) , WithBearer (..) , TraceLabelPeer (..) @@ -22,6 +23,7 @@ import Text.Printf import Control.Exception hiding (throwIO) import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI +import Control.Tracer (Tracer) import Data.Bifunctor (Bifunctor (..)) import Data.Word import GHC.Generics (Generic (..)) @@ -118,9 +120,19 @@ data BearerState = Mature -- closed. deriving (Eq, Show) +-- todo The Trace type mixes tags which are output by +-- separate components but share the type. It would make more sense +-- to break this up into separate types. Care must be +-- excercised to ensure that a particular tracer goes +-- into the component that outputs the desired tags. For instance, +-- the low level bearer tags are not output by the tracer which +-- is passed to Mux via 'Tracers'. + -- | Enumeration of Mux events that can be traced. -- data Trace = + -- low level bearer trace tags (these are not traced by the tracer + -- which is passed to Mux) TraceRecvHeaderStart | TraceRecvHeaderEnd SDUHeader | TraceRecvDeltaQObservation SDUHeader Time @@ -131,19 +143,30 @@ data Trace = | TraceSendStart SDUHeader | TraceSendEnd | TraceState BearerState - | TraceCleanExit MiniProtocolNum MiniProtocolDir - | TraceExceptionExit MiniProtocolNum MiniProtocolDir SomeException - | TraceChannelRecvStart MiniProtocolNum - | TraceChannelRecvEnd MiniProtocolNum Int - | TraceChannelSendStart MiniProtocolNum Int - | TraceChannelSendEnd MiniProtocolNum + | TraceSDUReadTimeoutException + | TraceSDUWriteTimeoutException + | TraceTCPInfo StructTCPInfo Word16 + -- low level handshake bearer tags (not traced by tracer in Mux) | TraceHandshakeStart | TraceHandshakeClientEnd DiffTime | TraceHandshakeServerEnd | forall e. Exception e => TraceHandshakeClientError e DiffTime | forall e. Exception e => TraceHandshakeServerError e - | TraceSDUReadTimeoutException - | TraceSDUWriteTimeoutException + -- mid level channel tags traced independently by each mini protocol + -- job in Mux, for each complete message, by the 'channelTracer' + -- within 'Tracers' + | TraceChannelRecvStart MiniProtocolNum + | TraceChannelRecvEnd MiniProtocolNum Int + | TraceChannelSendStart MiniProtocolNum Int + | TraceChannelSendEnd MiniProtocolNum + -- high level Mux tags traced by the main Mux/Connection handler + -- thread forked by CM. These may be monitored by the inbound + -- governor information channel tracer. These should be traced + -- by muxTracer of 'Tracers' and their ordering + -- is significant at call sites or bad things will happen. + -- You have been warned. + | TraceCleanExit MiniProtocolNum MiniProtocolDir + | TraceExceptionExit MiniProtocolNum MiniProtocolDir SomeException | TraceStartEagerly MiniProtocolNum MiniProtocolDir | TraceStartOnDemand MiniProtocolNum MiniProtocolDir | TraceStartOnDemandAny MiniProtocolNum MiniProtocolDir @@ -151,7 +174,6 @@ data Trace = | TraceTerminating MiniProtocolNum MiniProtocolDir | TraceStopping | TraceStopped - | TraceTCPInfo StructTCPInfo Word16 instance Show Trace where show TraceRecvHeaderStart = printf "Bearer Receive Header Start" @@ -208,3 +230,18 @@ instance Show Trace where show (TraceTCPInfo _ len) = printf "TCPInfo len %d" len #endif +-- | Bundle of tracers passed to mux +-- Consult the 'Trace' type to determine which +-- tags are required/expected to be served by these tracers. +-- In principle, the channelTracer can be == muxTracer +-- but performance likely degrades in typical conditions +-- unnecessarily. +-- +data Tracers m = Tracers { + channelTracer :: Tracer m Trace, + -- ^ a low level tracer for events emitted by a bearer. It emits events as frequently + -- as receiving individual `SDU`s from the network. + muxTracer :: Tracer m Trace + -- ^ mux events which are emitted less frequently. It emits events which allow one + -- to observe the current state of a mini-protocol. + } diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 8a93c815c42..603cedcc33e 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -127,6 +127,9 @@ activeTracer = nullTracer _sayTracer :: MonadSay m => Tracer m String _sayTracer = Tracer say +nullTracers :: (Applicative m) => Mx.Tracers m +nullTracers = Mx.Tracers nullTracer nullTracer + -- -- Generators -- @@ -350,15 +353,17 @@ prop_mux_snd_recv (DummyRun messages) = ioProperty $ do clientBearer = queueChannelAsBearer sduLen - clientTracer + clientTracer' QueueChannel { writeQueue = client_w, readQueue = client_r } serverBearer = queueChannelAsBearer sduLen - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' clientApp = MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 2, @@ -418,17 +423,19 @@ prop_mux_snd_recv_bi (DummyRun messages) (DummyCapability clientCap) (DummyCapab let server_w = client_r server_r = client_w - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' clientBearer <- getBearer makeQueueChannelBearer (-1) - clientTracer + clientTracer' QueueChannel { writeQueue = client_w, readQueue = client_r } Nothing serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } Nothing @@ -529,18 +536,20 @@ prop_mux_snd_recv_compat messages = ioProperty $ do let server_w = client_r server_r = client_w - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' clientBearer <- getBearer makeQueueChannelBearer (-1) - clientTracer + clientTracer' QueueChannel { writeQueue = client_w, readQueue = client_r } Nothing serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } Nothing (verify, client_mp, server_mp) <- setupMiniReqRspCompat @@ -743,8 +752,10 @@ runMuxApplication :: DummyCapability -> Mx.Bearer IO -> IO Bool runMuxApplication (DummyCapability rspCap) initApps initBearer respApps respBearer = do - let clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + let clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' protNum = [1..] respApps' = zip protNum respApps initApps' = zip protNum initApps @@ -1016,18 +1027,21 @@ prop_mux_starvation (Uneven response0 response1) = let server_w = client_r server_r = client_w - clientTracer = contramap (Mx.WithBearer "client") activeTracer - serverTracer = contramap (Mx.WithBearer "server") activeTracer + clientTracer' = contramap (Mx.WithBearer "client") activeTracer + serverTracer' = contramap (Mx.WithBearer "server") activeTracer + clientTracer = Mx.Tracers clientTracer' clientTracer' + serverTracer = Mx.Tracers serverTracer' serverTracer' + clientBearer <- getBearer makeQueueChannelBearer (-1) - clientTracer + (clientTracer' <> headerTracer) QueueChannel { writeQueue = client_w, readQueue = client_r } Nothing serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } Nothing (client_short, server_short) <- @@ -1072,7 +1086,7 @@ prop_mux_starvation (Uneven response0 response1) = Mx.StartOnDemand server_long clientMux <- Mx.new [clientApp2, clientApp3] - clientMux_aid <- async $ Mx.run (clientTracer <> headerTracer) clientMux clientBearer + clientMux_aid <- async $ Mx.run clientTracer clientMux clientBearer clientRes2 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp2) (miniProtocolDir clientApp2) Mx.StartEagerly client_short clientRes3 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp3) (miniProtocolDir clientApp3) @@ -1261,11 +1275,12 @@ prop_demux_sdu a = do server_w <- atomically $ newTBQueue 10 server_r <- atomically $ newTBQueue 10 - let serverTracer = contramap (Mx.WithBearer "server") activeTracer + let serverTracer' = contramap (Mx.WithBearer "server") activeTracer + serverTracer = Mx.Tracers serverTracer' serverTracer' serverBearer <- getBearer makeQueueChannelBearer (-1) - serverTracer + serverTracer' QueueChannel { writeQueue = server_w, readQueue = server_r } @@ -1576,7 +1591,7 @@ prop_mux_restart_m (DummyRestartingInitiatorApps apps) = do let minis = map (appToInfo Mx.InitiatorDirectionOnly . fst) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1625,7 +1640,7 @@ prop_mux_restart_m (DummyRestartingResponderApps rapps) = do minis = map (appToInfo Mx.ResponderDirectionOnly) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1677,7 +1692,7 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do respMinis = map (appToInfo Mx.ResponderDirection) apps mux <- Mx.new $ initMinis ++ respMinis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1762,7 +1777,7 @@ prop_mux_start_m bearer _ checkRes (DummyInitiatorApps apps) runTime _ = do minRunTime = minimum $ runTime : (map daRunTime $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracers mux bearer killer <- async $ (threadDelay runTime) >> Mx.stop mux getRes <- sequence [ Mx.runMiniProtocol mux @@ -1786,7 +1801,7 @@ prop_mux_start_m bearer trigger checkRes (DummyResponderApps apps) runTime anySt ) $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new minis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run muxVerboseTracer mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1816,7 +1831,7 @@ prop_mux_start_m bearer _trigger _checkRes (DummyResponderAppsKillMux apps) runT let minis = map (appToInfo Mx.ResponderDirectionOnly) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run muxVerboseTracer mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1839,7 +1854,7 @@ prop_mux_start_m bearer trigger checkRes (DummyInitiatorResponderApps apps) runT minRunTime = minimum $ runTime : (map (\a -> daRunTime a) $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new $ initMinis ++ respMinis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run muxVerboseTracer mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1917,6 +1932,14 @@ verboseTracer :: forall a m. => Tracer m a verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say +muxVerboseTracer :: forall m. + ( MonadAsync m + , MonadMonotonicTime m + , MonadSay m + ) + => Mx.Tracers m +muxVerboseTracer = Mx.Tracers verboseTracer verboseTracer + threadAndTimeTracer :: forall a m. ( MonadAsync m , MonadMonotonicTime m @@ -1998,6 +2021,10 @@ close_experiment _iotest #endif fault tracer muxTracer clientCtx serverCtx reqs0 fn acc0 = do + let clientMuxTracer' = (Client,) `contramap` muxTracer + serverMuxTracer' = (Server,) `contramap` muxTracer + clientMuxTracer = Mx.Tracers clientMuxTracer' clientMuxTracer' + serverMuxTracer = Mx.Tracers serverMuxTracer' serverMuxTracer' withAsync -- run client thread (bracket (Mx.new [ MiniProtocolInfo { @@ -2009,7 +2036,7 @@ close_experiment ]) Mx.stop $ \mux -> withNetworkCtx clientCtx $ \clientBearer -> - withAsync (Mx.run ((Client,) `contramap` muxTracer) mux clientBearer) $ \_muxAsync -> + withAsync (Mx.run clientMuxTracer mux clientBearer) $ \_muxAsync -> Mx.runMiniProtocol mux miniProtocolNum Mx.InitiatorDirectionOnly Mx.StartEagerly @@ -2028,7 +2055,7 @@ close_experiment ]) Mx.stop $ \mux -> withNetworkCtx serverCtx $ \serverBearer -> - withAsync (Mx.run ((Server,) `contramap` muxTracer) mux serverBearer) $ \_muxAsync -> do + withAsync (Mx.run serverMuxTracer mux serverBearer) $ \_muxAsync -> do Mx.runMiniProtocol mux miniProtocolNum Mx.ResponderDirectionOnly Mx.StartOnDemand diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 883767fc11d..2dbd025ad38 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -4,6 +4,16 @@ ### Breaking changes +* IG performance related improvements changing to interfaces of + * IG `with` and `Arguments` + * CM `with` and `Arguments` + * Server `with` and `Arguments` + * Deleted `InboundGovernor.Event` module and moved to InboundGovernor: + * `NewConnectionInfo`, `Event`, `EventSignal`, `Terminated`, `firstPeerCommitRemote` + * signature of `makeConnectionHandler` + * moved `InboundGovernorInfoChannel` to IG from InformationChannel + and changed its type to contain `Event`'s. + ### Non-breaking changes * Added `terminatingConns` to `ConnectionManagerCounters` diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 12727ffa25a..0754dbfe1a1 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- just to use 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -40,6 +41,7 @@ import Data.Functor (($>)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty (..)) import Data.Typeable (Typeable) +import Data.Void import Network.Mux qualified as Mux import Network.Mux.Bearer qualified as Mux @@ -59,11 +61,12 @@ import Network.TypedProtocol.ReqResp.Type (ReqResp) import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionManager.Core qualified as CM -import Ouroboros.Network.ConnectionManager.InformationChannel - (newInformationChannel) import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context +import Ouroboros.Network.InboundGovernor qualified as InboundGovernor +import Ouroboros.Network.InboundGovernor.InformationChannel + (newInformationChannel) import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode @@ -205,6 +208,7 @@ withBidirectionalConnectionManager Mux.InitiatorResponderMode socket peerAddr UnversionedProtocolData UnversionedProtocol ByteString m () () -> peerAddr + -> Async m Void -> m a) -> m a withBidirectionalConnectionManager snocket makeBearer socket @@ -229,36 +233,8 @@ withBidirectionalConnectionManager snocket makeBearer socket establishedRequestsVar <- LazySTM.newTVarIO establishedInitiatorRequests let muxTracer = ("mux",) `contramap` nullTracer -- mux tracer - CM.with - CM.Arguments { - -- ConnectionManagerTrace - CM.tracer = ("cm",) `contramap` debugTracer, - CM.trTracer = ("cm-state",) `contramap` debugTracer, - -- MuxTracer - CM.muxTracer = muxTracer, - CM.ipv4Address = localAddress, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \_ _ -> return (), - CM.timeWaitTimeout = timeWaitTimeout, - CM.outboundIdleTimeout = protocolIdleTimeout, - CM.connectionDataFlow = \_ -> Duplex, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen = stdGen, - CM.connectionsLimits = AcceptedConnectionsLimit { - acceptedConnectionsHardLimit = maxBound, - acceptedConnectionsSoftLimit = maxBound, - acceptedConnectionsDelay = 0 - }, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply - } - (makeConnectionHandler + mkConnectionHandler = makeConnectionHandler muxTracer - SingInitiatorResponderMode noBindForkPolicy HandshakeArguments { -- TraceSendRecv @@ -274,26 +250,60 @@ withBidirectionalConnectionManager snocket makeBearer socket warmRequestsVar establishedRequestsVar)) (mainThreadId, debugMuxErrorRethrowPolicy - <> debugIOErrorRethrowPolicy)) - (\_ -> HandshakeFailure) - (InResponderMode inbgovInfoChannel) - $ \connectionManager -> do - serverAddr <- Snocket.getLocalAddr snocket socket - Server.with - Server.Arguments { - Server.sockets = socket :| [], - Server.snocket = snocket, - Server.tracer = ("server",) `contramap` debugTracer, -- ServerTrace - Server.trTracer = nullTracer, - Server.inboundGovernorTracer = ("inbound-governor",) `contramap` debugTracer, - Server.debugInboundGovernor = nullTracer, - Server.connectionLimits = AcceptedConnectionsLimit maxBound maxBound 0, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = \_ -> Duplex, - Server.inboundIdleTimeout = Just protocolIdleTimeout, - Server.inboundInfoChannel = inbgovInfoChannel + <> debugIOErrorRethrowPolicy) + + withConnectionManager connectionHandler k' = + CM.with + CM.Arguments { + -- ConnectionManagerTrace + tracer = ("cm",) `contramap` debugTracer, + trTracer = ("cm-state",) `contramap` debugTracer, + -- MuxTracer + muxTracer = muxTracer, + ipv4Address = localAddress, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket = snocket, + makeBearer = makeBearer, + CM.withBuffer = \f -> f Nothing, + configureSocket = \_ _ -> return (), + timeWaitTimeout = timeWaitTimeout, + outboundIdleTimeout = protocolIdleTimeout, + connectionDataFlow = \_ -> Duplex, + prunePolicy = simplePrunePolicy, + stdGen = stdGen, + connectionsLimits = AcceptedConnectionsLimit { + acceptedConnectionsHardLimit = maxBound, + acceptedConnectionsSoftLimit = maxBound, + acceptedConnectionsDelay = 0 + }, + updateVersionData = \a _ -> a, + connStateIdSupply, + classifyHandleError = (\_ -> HandshakeFailure) } - (\_ _ -> k connectionManager serverAddr) + (InResponderMode inbgovInfoChannel) + connectionHandler + k' + + serverAddr <- Snocket.getLocalAddr snocket socket + Server.with + Server.Arguments { + sockets = socket :| [], + snocket = snocket, + tracer = ("server",) `contramap` debugTracer, -- ServerTrace + connectionLimits = AcceptedConnectionsLimit maxBound maxBound 0, + inboundGovernorArgs = + InboundGovernor.Arguments { + transitionTracer = nullTracer, + tracer = ("inbound-governor",) `contramap` debugTracer, + debugTracer = nullTracer, + connectionDataFlow = \_ -> Duplex, + infoChannel = inbgovInfoChannel, + idleTimeout = Just protocolIdleTimeout, + withConnectionManager, + mkConnectionHandler = mkConnectionHandler . MuxInitiatorResponderConnectionHandler (\_ -> Duplex) } + } + (\inbGovAsync _ connManager-> k connManager serverAddr inbGovAsync) where serverApplication :: LazySTM.TVar m [[Int]] -> LazySTM.TVar m [[Int]] @@ -478,7 +488,7 @@ bidirectionalExperiment snocket makeBearer socket0 connStateIdSupply protocolIdleTimeout timeWaitTimeout (Just localAddr) stdGen clientAndServerData $ - \connectionManager _serverAddr -> forever' $ do + \connectionManager _serverAddr _inbGovAsync -> forever' $ do -- runInitiatorProtocols returns a list of results per each protocol -- in each bucket (warm \/ hot \/ established); but we run only one -- mini-protocol. We can use `concat` to flatten the results. 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 d6eb888c236..97301ab39bf 100644 --- a/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -367,7 +367,7 @@ prop_socket_recv_error f rerr = [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb initiator respCtx)] ] - withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) mux bearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop mux wait aid diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index d89900d161e..4cea783cfff 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -31,7 +31,6 @@ library Ouroboros.Network.ConnectionId Ouroboros.Network.ConnectionManager.ConnMap Ouroboros.Network.ConnectionManager.Core - Ouroboros.Network.ConnectionManager.InformationChannel Ouroboros.Network.ConnectionManager.State Ouroboros.Network.ConnectionManager.Types Ouroboros.Network.Context @@ -41,7 +40,7 @@ library Ouroboros.Network.Driver.Stateful Ouroboros.Network.IOManager Ouroboros.Network.InboundGovernor - Ouroboros.Network.InboundGovernor.Event + Ouroboros.Network.InboundGovernor.InformationChannel Ouroboros.Network.InboundGovernor.State Ouroboros.Network.Mux Ouroboros.Network.MuxMode @@ -68,6 +67,7 @@ library Win32-network ^>=0.2, base >=4.12 && <4.22, bytestring >=0.10 && <0.13, + cardano-strict-containers, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer, 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 38b557b2aaa..ededf90f7c8 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -70,9 +71,9 @@ import Ouroboros.Network.Snocket (Accept (..), Accepted (..), import Test.Ouroboros.Network.ConnectionManager.Utils (verifyAbstractTransition) -import Ouroboros.Network.ConnectionManager.InformationChannel +import Ouroboros.Network.InboundGovernor.InformationChannel (newInformationChannel) -import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel +import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoChannel @@ -762,32 +763,31 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = let connectionHandler = mkConnectionHandler snocket result <- CM.with CM.Arguments { - CM.tracer, - CM.trTracer, - CM.muxTracer = nullTracer, - CM.ipv4Address = myAddress, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeFDBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \_ _ -> return (), - CM.connectionDataFlow = id, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen = Random.mkStdGen rnd, - CM.connectionsLimits = AcceptedConnectionsLimit { - acceptedConnectionsHardLimit = maxBound, - acceptedConnectionsSoftLimit = maxBound, - acceptedConnectionsDelay = 0 - }, - CM.timeWaitTimeout = testTimeWaitTimeout, - CM.outboundIdleTimeout = testOutboundIdleTimeout, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply - } - connectionHandler - (\_ -> HandshakeFailure) - (InResponderMode inbgovInfoChannel) + tracer, + trTracer, + muxTracer = nullTracer, + ipv4Address = myAddress, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket = snocket, + makeBearer = makeFDBearer, + withBuffer = \f -> f Nothing, + configureSocket = \_ _ -> return (), + connectionDataFlow = id, + prunePolicy = simplePrunePolicy, + stdGen = Random.mkStdGen rnd, + connectionsLimits = AcceptedConnectionsLimit { + acceptedConnectionsHardLimit = maxBound, + acceptedConnectionsSoftLimit = maxBound, + acceptedConnectionsDelay = 0 + }, + timeWaitTimeout = testTimeWaitTimeout, + outboundIdleTimeout = testOutboundIdleTimeout, + updateVersionData = \a _ -> a, + connStateIdSupply, + classifyHandleError = \_ -> HandshakeFailure } + (InResponderMode inbgovInfoChannel) + connectionHandler $ \(connectionManager :: ConnectionManager Mx.InitiatorResponderMode (FD (IOSim s)) Addr (Handle m) Void (IOSim s)) -> do diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index 8d6dabaa02d..5a4bde965f6 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -106,7 +106,7 @@ import Test.Ouroboros.Network.InboundGovernor.Utils validRemoteTransitionMap, verifyRemoteTransition, verifyRemoteTransitionOrder) import Test.Ouroboros.Network.Orphans () -import Test.Ouroboros.Network.Utils (WithName (..), WithTime (..), +import Test.Ouroboros.Network.Utils (WithName (..), WithTime (..), debugTracerG, genDelayWithPrecision, nightlyTest, sayTracer, tracerWithTime) import Test.Simulation.Network.Snocket hiding (tests) @@ -226,7 +226,7 @@ data ConnectionEvent req peerAddr -- ^ Close an outbound connection. | ShutdownClientServer DiffTime peerAddr -- ^ Shuts down a client/server (simulates power loss) - deriving (Show, Functor) + deriving (Eq, Show, Functor) -- | A sequence of connection events that make up a test scenario for `prop_multinode_Sim`. data MultiNodeScript req peerAddr = MultiNodeScript @@ -458,7 +458,7 @@ maxAcceptedConnectionsLimit = AcceptedConnectionsLimit maxBound maxBound 0 -- -- transitions. -- -instance Arbitrary req => +instance (Eq req, Arbitrary req) => Arbitrary (MultiNodePruningScript req) where arbitrary = do Positive len <- scale ((* 2) . (`div` 3)) arbitrary @@ -532,17 +532,20 @@ instance Arbitrary req => -- we could miss which change actually introduces the failure, and be lift -- with a larger counter example. shrink (MultiNodePruningScript - (AcceptedConnectionsLimit hardLimit softLimit delay) + acl@(AcceptedConnectionsLimit hardLimit softLimit delay) events attenuationMap) = - MultiNodePruningScript - <$> (AcceptedConnectionsLimit - <$> shrink hardLimit - <*> shrink softLimit - <*> pure delay) - <*> (makeValid - <$> shrinkList shrinkEvent events) - <*> shrink attenuationMap + let acls = AcceptedConnectionsLimit + <$> shrink hardLimit + <*> shrink softLimit + <*> pure delay in + [MultiNodePruningScript acl' events attenuationMap + | acl' <- acls] <> + [MultiNodePruningScript acl events' attenuationMap + | events' <- makeValid <$> shrinkList shrinkEvent events + , events' /= events] <> + [MultiNodePruningScript acl events attenuationMap' + | attenuationMap' <- shrink attenuationMap] where makeValid = go (ScriptState [] [] [] [] []) where @@ -635,6 +638,7 @@ multinodeExperiment (CM.Trace peerAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) + -> Tracer m (WithName (Name peerAddr) (Mux.WithBearer (ConnectionId peerAddr) Mux.Trace)) -> StdGen -> Snocket m socket peerAddr -> Mux.MakeBearer m socket @@ -647,7 +651,7 @@ multinodeExperiment -> MultiNodeScript req peerAddr -> m () multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer - stdGen0 snocket makeBearer addrFamily serverAddr accInit + muxTracer stdGen0 snocket makeBearer addrFamily serverAddr accInit dataFlow0 acceptedConnLimit (MultiNodeScript script _) = withJobPool $ \jobpool -> do @@ -746,7 +750,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer forkJob jobpool $ Job ( withInitiatorOnlyConnectionManager - name simTimeouts nullTracer nullTracer stdGen + name simTimeouts nullTracer cmTracer stdGen snocket makeBearer connStateIdSupply (Just localAddr) (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit @@ -783,7 +787,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer Job ( withBidirectionalConnectionManager name simTimeouts inboundTrTracer trTracer cmTracer - inboundTracer debugTracer + inboundTracer muxTracer debugTracer stdGen snocket makeBearer connStateIdSupply (\_ -> pure ()) fd (Just localAddr) serverAcc @@ -1122,6 +1126,8 @@ prop_connection_manager_no_invalid_traces (Fixed rnd) serverAcc (ArbDataFlow dat , ppScript (MultiNodeScript events attenuationMap) , "========== ConnectionManager Events ==========" , Trace.ppTrace show show connectionManagerEvents + , "====== Say Events ======" + , intercalate "\n" $ selectTraceEventsSay' trace ]) . bifoldMap ( \ case @@ -1429,6 +1435,7 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) ( sayTracer <> Tracer traceM <> networkStateTracer getState) + debugTracerG (mkStdGen rnd) snocket makeFDBearer @@ -1485,6 +1492,7 @@ prop_timeouts_enforced (Fixed rnd) serverAcc (ArbDataFlow dataFlow) dynamicTracer nullTracer dynamicTracer + debugTracerG -- | Property wrapping `multinodeExperiment`. -- @@ -1898,30 +1906,34 @@ prop_connection_manager_pruning (Fixed rnd) serverAcc -> Maybe (Either (WithName (Name SimAddr) (AbstractTransitionTrace SimAddr)) (WithName (Name SimAddr) (CM.Trace SimAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)))) - fn _ (EventLog dyn) = Left <$> fromDynamic dyn - <|> Right <$> fromDynamic dyn + fn _ (EventLog dyn) = fromDynamic dyn fn _ _ = Nothing in tabulate "ConnectionEvents" (map showConnectionEvents events) - -- . counterexample (ppScript (MultiNodeScript events attenuationMap)) + . counterexample (ppScript (MultiNodeScript events attenuationMap)) + . counterexample (concat + [ "\n\n====== Say Events ======\n" + , intercalate "\n" $ selectTraceEventsSay' trace + , "\n" + ]) . mkPropertyPruning . bifoldMap ( \ case MainReturn {} -> mempty - v -> mempty { tpProperty = counterexample (show v) False } + v -> mempty { tpProperty = counterexample ("\ncounterexample: " <> show v) False } ) ( \ case Left trs -> TestProperty { tpProperty = (counterexample $! - ( "\nconnection:\n" + ( "\ncounterexample\nconnection:\n" ++ intercalate "\n" (map ppTransition trs)) ) . foldMap ( \ tr -> All . (counterexample $! - ( "\nUnexpected transition: " + ( "\ncounterexample\nUnexpected transition: " ++ show tr) ) . verifyAbstractTransition @@ -1937,8 +1949,11 @@ prop_connection_manager_pruning (Fixed rnd) serverAcc tpActivityTypes = [classifyActivityType trs], tpTransitions = trs } - Right b -> - mempty { tpNumberOfPrunings = classifyPruning b } + Right b + | CM.TrUnexpectedlyFalseAssertion assertionLoc <- b -> + mempty { tpProperty = counterexample ("\ncounterexample: " <> show assertionLoc) False } + | otherwise -> + mempty { tpNumberOfPrunings = classifyPruning b } ) . fmap (first (map ttTransition)) . groupConnsEither id abstractStateIsFinalTransition @@ -2196,7 +2211,7 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = withBidirectionalConnectionManager "node-0" simTimeouts nullTracer nullTracer nullTracer nullTracer - nullTracer + nullTracer nullTracer (mkStdGen rnd) snock makeFDBearer @@ -2260,6 +2275,8 @@ multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m (WithName (Name SimAddr) (IG.Trace SimAddr)) -> Tracer m (WithName (Name SimAddr) (IG.Debug SimAddr DataFlowProtocolData)) + -> Tracer m + (WithName (Name SimAddr) (Mux.WithBearer (ConnectionId SimAddr) Mux.Trace)) -> Tracer m (WithName (Name SimAddr) @@ -2271,7 +2288,7 @@ multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap remoteTrTracer abstractTrTracer - inboundGovTracer debugTracer connMgrTracer = do + inboundGovTracer debugTracer muxTracer connMgrTracer = do let attenuationMap' = (fmap toBearerInfo <$>) . Map.mapKeys ( normaliseId @@ -2289,6 +2306,7 @@ multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo inboundGovTracer debugTracer connMgrTracer + muxTracer stdGen snocket makeFDBearer @@ -2323,7 +2341,7 @@ multiNodeSim stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap = do multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap dynamicTracer dynamicTracer dynamicTracer - (Tracer traceM) dynamicTracer + (Tracer traceM) dynamicTracer dynamicTracer --debugTracerG -- | Connection terminated while negotiating it. 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 2472c829b9b..2dbeecb0135 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Socket.hs @@ -372,7 +372,7 @@ prop_socket_recv_error f rerr = [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb initiator respCtx)] ] - withAsync (Mx.run nullTracer mux bearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) mux bearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop mux wait aid diff --git a/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs index 0e5795366b1..9ca04b2f91c 100644 --- a/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/sim-tests/Test/Simulation/Network/Snocket.hs @@ -287,9 +287,11 @@ clientServerSimulation payloads = serverPeer) withAsync (do labelThisThread "server-mux" - Mx.run (("server", connId,) + let serverTracer = + (("server", connId,) `contramap` traceTime (Tracer (say . show))) + Mx.run (Mx.Tracers serverTracer serverTracer) mux bearer) $ \_muxThread -> do res <- atomically resSTM @@ -332,9 +334,11 @@ clientServerSimulation payloads = -- kill mux as soon as the client returns withAsync (do labelThisThread "client-mux" - Mx.run (("client", connId,) + let clientTracer = + (("client", connId,) `contramap` traceTime (Tracer (say . show))) + Mx.run (Mx.Tracers clientTracer clientTracer) mux bearer) $ \_ -> do res <- atomically resSTM diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index 93c07319336..c7a36351862 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -1,12 +1,14 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} -- | Implementation of 'ConnectionHandler' @@ -31,6 +33,7 @@ module Ouroboros.Network.ConnectionHandler , HandleWithMinimalCtx , HandleError (..) , classifyHandleError + , MkMuxConnectionHandler (..) , MuxConnectionHandler , makeConnectionHandler , MuxConnectionManager @@ -51,17 +54,20 @@ import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) import Data.Map (Map) +import Data.Maybe.Strict import Data.Text (Text) import Data.Typeable (Typeable) import Network.Mux (Mux) import Network.Mux qualified as Mx +import Network.Mux.Trace import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context (ExpandedInitiatorContext, MinimalInitiatorContext, ResponderContext) import Ouroboros.Network.ControlMessage (ControlMessage (..)) +import Ouroboros.Network.InboundGovernor.State import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode import Ouroboros.Network.Protocol.Handshake @@ -115,6 +121,22 @@ data Handle (muxMode :: Mx.Mode) initiatorCtx responderCtx versionData bytes m a hVersionData :: !versionData } +data MkMuxConnectionHandler (muxMode :: Mx.Mode) socket initiatorCtx responderCtx + peerAddr versionNumber versionData bytes m a b where + MuxInitiatorConnectionHandler :: MkMuxConnectionHandler + Mx.InitiatorMode socket initiatorCtx responderCtx + peerAddr versionNumber versionData bytes m a b + MuxResponderConnectionHandler :: ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace)) + -> MkMuxConnectionHandler + Mx.ResponderMode socket initiatorCtx responderCtx + peerAddr versionNumber versionData bytes m a b + MuxInitiatorResponderConnectionHandler + :: (versionData -> DataFlow) + -> ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace)) + -> MkMuxConnectionHandler Mx.InitiatorResponderMode socket initiatorCtx responderCtx peerAddr + versionNumber versionData bytes m a b -- | 'Handle' used by `node-to-node` P2P connections. -- @@ -207,6 +229,10 @@ type ConnectionManagerWithExpandedCtx muxMode socket peerAddr versionData versio -- different `ConnectionManager`s: one for `node-to-client` and another for -- `node-to-node` connections. But this is ok, as these resources are -- independent. +-- When a server is running, the inbound governor creates a tracer which is passed here, +-- and the connection handler appends it to the muxer tracer for +-- inbound and (negotiated) outbound duplex connections. This tracer +-- efficiently informs the IG loop of miniprotocol activity. -- makeConnectionHandler :: forall initiatorCtx responderCtx peerAddr muxMode socket versionNumber versionData m a b. @@ -223,33 +249,30 @@ makeConnectionHandler , Typeable peerAddr ) => Tracer m (Mx.WithBearer (ConnectionId peerAddr) Mx.Trace) - -> SingMuxMode muxMode -> ForkPolicy peerAddr - -- ^ describe whether this is outbound or inbound connection, and bring - -- evidence that we can use mux with it. -> HandshakeArguments (ConnectionId peerAddr) versionNumber versionData m -> Versions versionNumber versionData (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m a b) -> (ThreadId m, RethrowPolicy) -- ^ 'ThreadId' and rethrow policy. Rethrow policy might throw an async -- exception to that thread, when trying to terminate the process. - -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b -makeConnectionHandler muxTracer singMuxMode - forkPolicy + -> MkMuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr versionNumber versionData ByteString m a b + -> MuxConnectionHandler muxMode socket initiatorCtx responderCtx peerAddr + versionNumber versionData ByteString m a b +makeConnectionHandler muxTracer forkPolicy handshakeArguments versionedApplication (mainThreadId, rethrowPolicy) = - ConnectionHandler { - connectionHandler = - case singMuxMode of - SingInitiatorMode -> - WithInitiatorMode outboundConnectionHandler - SingResponderMode -> - WithResponderMode inboundConnectionHandler - SingInitiatorResponderMode -> - WithInitiatorResponderMode outboundConnectionHandler - inboundConnectionHandler - } + \case + MuxInitiatorConnectionHandler -> + ConnectionHandler . WithInitiatorMode + $ outboundConnectionHandler NotInResponderMode + MuxResponderConnectionHandler inboundGovernorMuxTracer -> + ConnectionHandler . WithResponderMode . inboundConnectionHandler $ inboundGovernorMuxTracer + MuxInitiatorResponderConnectionHandler connectionDataFlow inboundGovernorMuxTracer -> + ConnectionHandler $ WithInitiatorResponderMode + (outboundConnectionHandler $ InResponderMode (inboundGovernorMuxTracer, connectionDataFlow)) + (inboundConnectionHandler inboundGovernorMuxTracer) where -- install classify exception handler classifyExceptions :: forall x. @@ -276,7 +299,10 @@ makeConnectionHandler muxTracer singMuxMode outboundConnectionHandler :: HasInitiator muxMode ~ True - => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) + => InResponderMode muxMode ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace) + , versionData -> DataFlow) + -> ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) socket peerAddr (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) @@ -284,7 +310,8 @@ makeConnectionHandler muxTracer singMuxMode versionNumber versionData m - outboundConnectionHandler versionDataFn + outboundConnectionHandler inResponderMode + versionDataFn socket PromiseWriter { writePromise } tracer @@ -319,27 +346,37 @@ makeConnectionHandler muxTracer singMuxMode atomically $ writePromise (Left (HandleHandshakeClientError err)) traceWith tracer (TrHandshakeClientError err) - Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> - unmask $ do - traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) - controlMessageBundle - <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) - <$> newTVarIO Continue - <*> newTVarIO Continue - <*> newTVarIO Continue - mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) - let !handle = Handle { - hMux = mux, - hMuxBundle = app, - hControlMessage = controlMessageBundle, - hVersionData = agreedOptions - } - atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) - withBuffer (\buffer -> do - bearer <- mkMuxBearer sduTimeout socket buffer - Mx.run (Mx.WithBearer connectionId `contramap` muxTracer) - mux bearer - ) + Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> do + traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) + controlMessageBundle + <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) + <$> newTVarIO Continue + <*> newTVarIO Continue + <*> newTVarIO Continue + mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) + let !handle = Handle { + hMux = mux, + hMuxBundle = app, + hControlMessage = controlMessageBundle, + hVersionData = agreedOptions + } + atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) + withBuffer \buffer -> do + bearer <- mkMuxBearer sduTimeout socket buffer + muxTracer' <- + contramap (Mx.WithBearer connectionId) <$> case inResponderMode of + InResponderMode (inboundGovernorMuxTracer, connectionDataFlow) + | Duplex <- connectionDataFlow agreedOptions -> do + countersVar <- newTVarIO . SJust $ ResponderCounters 0 0 + pure $ muxTracer <> inboundGovernorMuxTracer countersVar + _notResponder -> + -- If this is InitiatorOnly, or a server where unidirectional flow was negotiated + -- the IG will never be informed of this remote for obvious reasons. + pure muxTracer + unmask $ Mx.run Mx.Tracers { + muxTracer = muxTracer', + channelTracer = Mx.WithBearer connectionId `contramap` muxTracer } + mux bearer Right (HandshakeQueryResult vMap) -> do atomically $ writePromise (Right HandshakeConnectionQuery) @@ -348,7 +385,9 @@ makeConnectionHandler muxTracer singMuxMode inboundConnectionHandler :: HasResponder muxMode ~ True - => ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) + => ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (WithBearer (ConnectionId peerAddr) Trace)) + -> ConnectionHandlerFn (ConnectionHandlerTrace versionNumber versionData) socket peerAddr (Handle muxMode initiatorCtx responderCtx versionData ByteString m a b) @@ -356,7 +395,8 @@ makeConnectionHandler muxTracer singMuxMode versionNumber versionData m - inboundConnectionHandler updateVersionDataFn + inboundConnectionHandler inboundGovernorMuxTracer + updateVersionDataFn socket PromiseWriter { writePromise } tracer @@ -391,28 +431,30 @@ makeConnectionHandler muxTracer singMuxMode Left !err -> do atomically $ writePromise (Left (HandleHandshakeServerError err)) traceWith tracer (TrHandshakeServerError err) - Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> - unmask $ do - traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) - controlMessageBundle - <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) - <$> newTVarIO Continue - <*> newTVarIO Continue - <*> newTVarIO Continue - mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) - - let !handle = Handle { - hMux = mux, - hMuxBundle = app, - hControlMessage = controlMessageBundle, - hVersionData = agreedOptions - } - atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) - withBuffer (\buffer -> do - bearer <- mkMuxBearer sduTimeout socket buffer - Mx.run (Mx.WithBearer connectionId `contramap` muxTracer) - mux bearer - ) + Right (HandshakeNegotiationResult app versionNumber agreedOptions) -> do + traceWith tracer (TrHandshakeSuccess versionNumber agreedOptions) + controlMessageBundle + <- (\a b c -> TemperatureBundle (WithHot a) (WithWarm b) (WithEstablished c)) + <$> newTVarIO Continue + <*> newTVarIO Continue + <*> newTVarIO Continue + mux <- Mx.new (mkMiniProtocolInfos (runForkPolicy forkPolicy remoteAddress) app) + + let !handle = Handle { + hMux = mux, + hMuxBundle = app, + hControlMessage = controlMessageBundle, + hVersionData = agreedOptions + } + atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) + withBuffer \buffer -> do + bearer <- mkMuxBearer sduTimeout socket buffer + countersVar <- newTVarIO . SJust $ ResponderCounters 0 0 + let traceWithBearer = contramap $ Mx.WithBearer connectionId + unmask $ Mx.run Mx.Tracers { + muxTracer = traceWithBearer (muxTracer <> inboundGovernorMuxTracer countersVar), + channelTracer = traceWithBearer muxTracer } + mux bearer Right (HandshakeQueryResult vMap) -> do atomically $ writePromise (Right HandshakeConnectionQuery) traceWith tracer $ TrHandshakeQuery vMap diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 97228a74eb9..d1d02260c2c 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + +--{-# OPTIONS_GHC -fno-ignore-asserts #-} -- | The implementation of connection manager. -- -- The module should be imported qualified. @@ -58,23 +60,21 @@ import Network.Mux.Trace qualified as Mx import Network.Mux.Types qualified as Mx import Ouroboros.Network.ConnectionId -import Ouroboros.Network.ConnectionManager.InformationChannel - (InformationChannel) -import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply, ConnectionManagerState, ConnectionState (..), MutableConnState (..)) import Ouroboros.Network.ConnectionManager.State qualified as State import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.InboundGovernor.Event (NewConnectionInfo (..)) +import Ouroboros.Network.InboundGovernor (Event (..), NewConnectionInfo (..)) +import Ouroboros.Network.InboundGovernor.InformationChannel (InformationChannel) +import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoChannel import Ouroboros.Network.MuxMode import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket - -- | Arguments for a 'ConnectionManager' which are independent of 'MuxMode'. -- -data Arguments handlerTrace socket peerAddr handle handleError versionNumber versionData m = +data Arguments handlerTrace socket peerAddr handle handleError versionNumber versionData m a b = Arguments { -- | Connection manager tracer. -- @@ -157,7 +157,9 @@ data Arguments handlerTrace socket peerAddr handle handleError versionNumber ver -- | Supply for `ConnStateId`-s. -- - connStateIdSupply :: ConnStateIdSupply m + connStateIdSupply :: ConnStateIdSupply m, + + classifyHandleError :: handleError -> HandleErrorType } @@ -360,7 +362,7 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- is responsible for the resource. -- with - :: forall (muxMode :: Mx.Mode) peerAddr socket handlerTrace handle handleError version versionData m a. + :: forall (muxMode :: Mx.Mode) peerAddr socket initiatorCtx handlerTrace handle handleError version versionData m a b x. ( Alternative (STM m) , MonadLabelledSTM m , MonadTraceSTM m @@ -378,19 +380,17 @@ with , Show peerAddr , Typeable peerAddr ) - => Arguments handlerTrace socket peerAddr handle handleError version versionData m - -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError version versionData m - -- ^ Callback which runs in a thread dedicated for a given connection. - -> (handleError -> HandleErrorType) - -- ^ classify 'handleError's - -> InResponderMode muxMode (InformationChannel (NewConnectionInfo peerAddr handle) m) + => Arguments handlerTrace socket peerAddr handle handleError version versionData m a b + -> InResponderMode muxMode (InformationChannel (Event muxMode handle initiatorCtx peerAddr versionData m a b) m) -- ^ On outbound duplex connections we need to notify the server about -- a new connection. - -> (ConnectionManager muxMode socket peerAddr handle handleError m -> m a) + -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError version versionData m + -- ^ ConnectionHandler which negotiates a connection and hosts the mux + -> (ConnectionManager muxMode socket peerAddr handle handleError m -> m x) -- ^ Continuation which receives the 'ConnectionManager'. It must not leak -- outside of scope of this callback. Once it returns all resources -- will be closed. - -> m a + -> m x with args@Arguments { tracer, trTracer, @@ -408,13 +408,13 @@ with args@Arguments { prunePolicy, connectionsLimits, updateVersionData, - connStateIdSupply + connStateIdSupply, + classifyHandleError } - ConnectionHandler { - connectionHandler - } - classifyHandleError inboundGovernorInfoChannel + ConnectionHandler { + connectionHandler + } k = do ((stateVar, stdGenVar) :: ( StrictTMVar m (ConnectionManagerState peerAddr handle handleError @@ -428,7 +428,7 @@ with args@Arguments { st' <- case mbst of Nothing -> pure Nothing Just st -> Just <$> traverse (inspectTVar (Proxy :: Proxy m) . toLazyTVar . connVar) st - return (TraceString (show st')) + return (TraceString ("cm-state: " <> show st')) stdGenVar <- newTVar (stdGen args) return (v, stdGenVar) @@ -1056,8 +1056,8 @@ with args@Arguments { case inboundGovernorInfoChannel of InResponderMode infoChannel -> atomically $ InfoChannel.writeMessage - infoChannel - (NewConnectionInfo provenance connId dataFlow handle) + infoChannel $ + NewConnection (NewConnectionInfo provenance connId dataFlow handle) _ -> return () return $ Connected connId dataFlow handle @@ -1075,7 +1075,7 @@ with args@Arguments { m (ConnectionManagerState peerAddr handle handleError version m) -> MutableConnState peerAddr handle handleError version m -> Maybe handleError - -> m (Connected peerAddr handle1 handleError) + -> m (Connected peerAddr handle handleError) terminateInboundWithErrorOrQuery connId connStateId connVar connThread stateVar mutableConnState handleErrorM = do transitions <- atomically $ do connState <- readTVar connVar @@ -1657,21 +1657,17 @@ with args@Arguments { -- → OutboundDupState^\tau Outbound -- @ let connState' = OutboundDupState connId connThread handle Ticking - notifyInboundGov = - case provenance' of - Inbound -> False - -- This is a connection to oneself; We don't - -- need to notify the inbound governor, as - -- it's already done by - -- `includeInboundConnectionImpl` - Outbound -> True writeTVar connVar connState' - case inboundGovernorInfoChannel of - InResponderMode infoChannel | notifyInboundGov -> - InfoChannel.writeMessage - infoChannel - (NewConnectionInfo provenance' connId dataFlow handle) - _ -> return () + case provenance' of + Outbound | InResponderMode infoChannel <- inboundGovernorInfoChannel -> + InfoChannel.writeMessage infoChannel . + NewConnection $ NewConnectionInfo provenance' connId dataFlow handle + -- This is a connection to oneself; We don't + -- need to notify the inbound governor, as + -- it's already done by + -- `includeInboundConnectionImpl` + _otherwise -> return () + return (Just $ mkTransition connState connState') -- @ diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index 39a4c5932ce..b8dcd7cd35d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- 'runResponder' is using a redundant constraint. {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -25,6 +27,8 @@ module Ouroboros.Network.InboundGovernor -- * Trace , Trace (..) , Debug (..) + , Event (..) + , NewConnectionInfo (..) , RemoteSt (..) , RemoteTransition , RemoteTransitionTrace @@ -32,6 +36,7 @@ module Ouroboros.Network.InboundGovernor -- * Re-exports , Transition' (..) , TransitionTrace' (..) + , ResponderCounters (..) -- * API's exported for testing purposes , maturedPeers ) where @@ -40,19 +45,20 @@ import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (SomeAsyncException (..)) -import Control.Monad (foldM) +import Control.Monad (foldM, forM_, forever, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI -import Control.Tracer (Tracer, traceWith) +import Control.Tracer (Tracer (..), traceWith) import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Cache import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe.Strict import Data.Monoid.Synchronisation import Data.OrdPSQ (OrdPSQ) import Data.OrdPSQ qualified as OrdPSQ @@ -61,19 +67,17 @@ import Data.Set qualified as Set import Data.Void (Void) import Network.Mux qualified as Mux +import Network.Mux.Types qualified as Mux import Ouroboros.Network.ConnectionHandler -import Ouroboros.Network.ConnectionManager.InformationChannel - (InboundGovernorInfoChannel) -import Ouroboros.Network.ConnectionManager.InformationChannel qualified as InfoChannel import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Context -import Ouroboros.Network.InboundGovernor.Event +import Ouroboros.Network.InboundGovernor.InformationChannel (InformationChannel) +import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoChannel import Ouroboros.Network.InboundGovernor.State import Ouroboros.Network.Mux import Ouroboros.Network.Server.RateLimiting - -- | Period of time after which a peer transitions from a fresh to a mature one, -- see `matureDuplexPeers` and `freshDuplexPeers`. -- @@ -88,7 +92,9 @@ inactionTimeout :: DiffTime inactionTimeout = 31.415927 -data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m a b = Arguments { +data Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx + handle handleError versionNumber versionData bytes m a b x = + Arguments { transitionTracer :: Tracer m (RemoteTransitionTrace peerAddr), -- ^ transition tracer tracer :: Tracer m (Trace peerAddr), @@ -103,11 +109,20 @@ data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m idleTimeout :: Maybe DiffTime, -- ^ protocol idle timeout. The remote site must restart a mini-protocol -- within given timeframe (Nothing indicates no timeout). - connectionManager :: MuxConnectionManager muxMode socket initiatorCtx - (ResponderContext peerAddr) peerAddr - versionData versionNumber - ByteString m a b - -- ^ connection manager + withConnectionManager + :: ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError versionNumber versionData m + -> (ConnectionManager muxMode socket peerAddr handle handleError m -> m x) + -> m x, + -- ^ connection manager continuation + mkConnectionHandler + :: ( StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (Mux.WithBearer (ConnectionId peerAddr) Mux.Trace)) + -> ConnectionHandler muxMode handlerTrace socket peerAddr handle handleError versionNumber versionData m + -- ^ Connection handler builder, which injects a special tracer + -- created here and routed into the muxer via the connection manager. + -- The purpose is to inform the IG loop + -- of miniprotocol responder activity such that proper and efficient + -- peer cold/warm/hot transitions can be tracked. } @@ -126,7 +141,8 @@ data Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m -- The first one is used in data diffusion for /Node-To-Node protocol/, while the -- other is useful for running a server for the /Node-To-Client protocol/. -- -with :: forall (muxMode :: Mux.Mode) socket initiatorCtx peerAddr versionData versionNumber m a b x. +with :: forall (muxMode :: Mux.Mode) socket peerAddr initiatorCtx responderCtx + handle handlerTrace handleError versionData versionNumber bytes m a b x. ( Alternative (STM m) , MonadAsync m , MonadCatch m @@ -139,31 +155,53 @@ with :: forall (muxMode :: Mux.Mode) socket initiatorCtx peerAddr versionData ve , MonadMask m , Ord peerAddr , HasResponder muxMode ~ True + , MonadTraceSTM m + , MonadFork m + , MonadDelay m + , Show peerAddr ) - => Arguments muxMode socket initiatorCtx peerAddr versionNumber versionData m a b - -> (Async m Void -> m (PublicState peerAddr versionData) -> m x) + => Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx + handle handleError versionNumber versionData bytes m a b x + -> ( Async m Void + -> m (PublicState peerAddr versionData) + -> ConnectionManager muxMode socket peerAddr handle handleError m + -> m x) -> m x with Arguments { - transitionTracer = trTracer, - tracer = tracer, - debugTracer = debugTracer, - connectionDataFlow = connectionDataFlow, - infoChannel = infoChannel, - idleTimeout = idleTimeout, - connectionManager = connectionManager + transitionTracer = trTracer, + tracer, + debugTracer, + connectionDataFlow, + idleTimeout, + infoChannel, + withConnectionManager, + mkConnectionHandler } k = do - labelThisThread "inbound-governor" - var <- newTVarIO (mkPublicState emptyState) - withAsync ((do - labelThisThread "inbound-governor-loop" - inboundGovernorLoop var emptyState) - `catch` - handleError var) $ + stateVar <- newTVarIO emptyState + active <- newTVarIO True -- ^ inbound governor status: True = Active + let connectionHandler = + mkConnectionHandler $ inboundGovernorMuxTracer infoChannel + connectionDataFlow + stateVar + active + withConnectionManager connectionHandler \connectionManager -> + withAsync + ( labelThisThread "inbound-governor-loop" >> + forever (inboundGovernorStep connectionManager stateVar >> yield) + `catch` \e -> do + -- following the next statement, the ig tracer will no longer + -- write to the info channel queue. + atomically $ writeTVar active False + -- To avoid the risk of a full information channel queue + -- and blocking on mux traces which will prevent connection cleanup, + -- we drain it here just in case one last time. + _ <- atomically $ InfoChannel.readMessages infoChannel + handleError stateVar e) \thread -> - k thread (readTVarIO var) + k thread (mkPublicState <$> readTVarIO stateVar) connectionManager where emptyState :: State muxMode initiatorCtx peerAddr versionData m a b emptyState = State { @@ -178,11 +216,11 @@ with -- NOTE: `inboundGovernorLoop` doesn't throw synchronous exceptions, this is -- just need to handle asynchronous exceptions. handleError - :: StrictTVar m (PublicState peerAddr versionData) + :: StrictTVar m (State muxMode initiatorCtx peerAddr versionData m a b) -> SomeException -> m Void handleError var e = do - PublicState { remoteStateMap } <- readTVarIO var + PublicState { remoteStateMap } <- mkPublicState <$> readTVarIO var _ <- Map.traverseWithKey (\connId remoteSt -> traceWith trTracer $ @@ -193,378 +231,492 @@ with remoteStateMap throwIO e - -- The inbound protocol governor recursive loop. The 'connections' is - -- updated as we recurse. - -- - inboundGovernorLoop - :: StrictTVar m (PublicState peerAddr versionData) - -> State muxMode initiatorCtx peerAddr versionData m a b - -> m Void - inboundGovernorLoop var !state = do + -- The inbound protocol governor single step, which may + -- process multipe events from the information channel + inboundGovernorStep + :: ConnectionManager muxMode socket peerAddr handle handleError m + -> StrictTVar m (State muxMode initiatorCtx peerAddr versionData m a b) + -> m () + inboundGovernorStep connectionManager stateVar = do time <- getMonotonicTime inactivityVar <- registerDelay inactionTimeout + events <- atomically do + state <- readTVar stateVar + runFirstToFinish $ + -- we deliberately read the info channel queue after + -- the relevant item in each firsttofinish to limit + -- contention + FirstToFinish do + -- mark connections as mature + case maturedPeers time (freshDuplexPeers state) of + (as, _) | Map.null as + -> retry + (as, fresh) -> + (MaturedDuplexPeers as fresh :) <$> InfoChannel.readMessages infoChannel + <> FirstToFinish do + firstCommit <- runFirstToFinish $ + Map.foldMapWithKey firstPeerCommitRemote (connections state) + -- it is important we read the channel here, and join it after + -- the firstCommit. Registering responder starts are atomic wrt + -- handling an expired peer in the tracer. If the CM drops the + -- expired connection (CommitRemote below), the tracer must not + -- register a promotion activity. + (firstCommit :) <$> InfoChannel.readMessages infoChannel + <> FirstToFinish do + muxEvents <- InfoChannel.readMessages infoChannel + check (not . null $ muxEvents) >> pure muxEvents + <> FirstToFinish do + -- spin the inbound governor loop; it will re-run with new + -- time, which allows to make some peers mature. + LazySTM.readTVar inactivityVar >>= check >> pure [InactivityTimeout] + + forM_ events \event -> do + state <- readTVarIO stateVar + decision <- case event of + NewConnection + -- new connection has been announced by either accept loop or + -- by connection manager (in which case the connection is in + -- 'DuplexState'). + (NewConnectionInfo + provenance + connId + dataFlow + Handle { + hMux = csMux, + hMuxBundle = muxBundle, + hVersionData = csVersionData + }) -> do + + traceWith tracer (TrNewConnection provenance connId) + let responderContext = ResponderContext { rcConnectionId = connId } + + connections <- Map.alterF + (\case + -- connection + Nothing -> do + let csMPMHot = + [ ( miniProtocolNum mpH + , MiniProtocolData mpH responderContext Hot + ) + | mpH <- projectBundle SingHot muxBundle + ] + csMPMWarm = + [ ( miniProtocolNum mpW + , MiniProtocolData mpW responderContext Warm + ) + | mpW <- projectBundle SingWarm muxBundle + ] + csMPMEstablished = + [ ( miniProtocolNum mpE + , MiniProtocolData mpE responderContext Established + ) + | mpE <- projectBundle SingEstablished muxBundle + ] + csMiniProtocolMap = + Map.fromList + (csMPMHot ++ csMPMWarm ++ csMPMEstablished) + + mCompletionMap + <- + foldM + (\acc mpd@MiniProtocolData { mpdMiniProtocol } -> + runResponder csMux mpd >>= \case + -- synchronous exceptions when starting + -- a mini-protocol are non-recoverable; we + -- close the connection and allow the server + -- to continue. + Left err -> do + traceWith tracer (TrResponderStartFailure connId (miniProtocolNum mpdMiniProtocol) err) + Mux.stop csMux + return Nothing + + Right completion -> do + let acc' = Map.insert (miniProtocolNum mpdMiniProtocol) + completion + <$> acc + -- force under lazy 'Maybe' + case acc' of + Just !_ -> return acc' + Nothing -> return acc' + ) + (Just Map.empty) + csMiniProtocolMap + + case mCompletionMap of + -- there was an error when starting one of the + -- responders, we let the server continue without this + -- connection. + Nothing -> return Nothing + + Just csCompletionMap -> do + mv <- traverse registerDelay idleTimeout + let -- initial state is 'RemoteIdle', if the remote end will not + -- start any responders this will unregister the inbound side. + csRemoteState :: RemoteState m + csRemoteState = RemoteIdle (case mv of + Nothing -> pure False + Just v -> LazySTM.readTVar v) + + connState = ConnectionState { + csMux, + csVersionData, + csMiniProtocolMap, + csCompletionMap, + csRemoteState + } + + return (Just connState) + + -- inbound governor might be notified about a connection + -- which is already tracked. In such case we preserve its + -- state. + -- + -- In particular we preserve an ongoing timeout on + -- 'RemoteIdle' state. + Just connState -> return (Just connState) + + ) + connId + (connections state) + + -- update state and continue the recursive loop + let state' = state { + connections, + freshDuplexPeers = + case dataFlow of + Unidirectional -> freshDuplexPeers state + Duplex -> OrdPSQ.insert (remoteAddress connId) time csVersionData + (freshDuplexPeers state) + } + return . Just $ StateWithPeerTransition state' connId + + MuxFinished connId result -> do + + merr <- atomically result + case merr of + Nothing -> traceWith tracer (TrMuxCleanExit connId) + Just err -> traceWith tracer (TrMuxErrored connId err) + + -- the connection manager does should realise this on itself. + -- we bypass the assertion check since MuxFinished could have been + -- placed on the queue by a racing thread before we managed + -- to remove the connection from our state at the end of this loop. + let state' = unregisterConnection True connId state + return . Just $ StateWithPeerTransition state' connId -- ^ even though it might not be true, but it's benign + + MiniProtocolTerminated + Terminated { + tConnId, + tMux, + tMiniProtocolData = mpd@MiniProtocolData { mpdMiniProtocol = miniProtocol }, + tResult + } -> do + tResult' <- atomically tResult + let num = miniProtocolNum miniProtocol + case tResult' of + Left e -> do + -- a mini-protocol errored. In this case mux will shutdown, and + -- the connection manager will tear down the socket. Before bailing out, + -- the IG tracer will emit BearState Dead which will unregister the connection + -- in some following iteration via MuxFinished, but for this peer it should + -- be the very next message. + traceWith tracer $ + TrResponderErrored tConnId num e + return Nothing + + Right _ -> + runResponder tMux mpd >>= \case + Right completionAction -> do + traceWith tracer (TrResponderRestarted tConnId num) + let state' = updateMiniProtocol tConnId num completionAction state + return . Just $ OnlyStateChange state' + + Left err -> do + -- there is no way to recover from synchronous exceptions; we + -- stop mux which allows to close resources held by + -- connection manager. + traceWith tracer (TrResponderStartFailure tConnId num err) + Mux.stop tMux + return Nothing + + WaitIdleRemote connId -> do + -- @ + -- DemotedToCold^{dataFlow}_{Remote} : InboundState Duplex + -- → InboundIdleState Duplex + -- @ + -- NOTE: `demotedToColdRemote` doesn't throw, hence exception handling + -- is not needed. + res <- demotedToColdRemote connectionManager connId + traceWith tracer (TrWaitIdleRemote connId res) + case res of + OperationSuccess {} -> do + mv <- traverse registerDelay idleTimeout + let timeoutSTM :: STM m Bool + !timeoutSTM = case mv of + Nothing -> pure False + Just v -> LazySTM.readTVar v + + state' = updateRemoteState connId (RemoteIdle timeoutSTM) state + + return . Just $ StateWithPeerTransition state' connId + -- if the connection handler failed by this time, it will have + -- written BearerState Dead to the IG tracer and we will handle this + -- in MuxFinished case on the next iteration, where it will unregister + -- the connection + _otherwise -> return Nothing - event - <- atomically $ runFirstToFinish $ - FirstToFinish ( - -- mark connections as mature - case maturedPeers time (freshDuplexPeers state) of - (as, _) | Map.null as - -> retry - (as, fresh) -> pure $ MaturedDuplexPeers as fresh - ) - <> Map.foldMapWithKey - ( firstMuxToFinish - <> firstPeerDemotedToCold - <> firstPeerCommitRemote - <> firstMiniProtocolToFinish connectionDataFlow - <> firstPeerPromotedToWarm - <> firstPeerPromotedToHot - <> firstPeerDemotedToWarm - - :: EventSignal muxMode initiatorCtx peerAddr versionData m a b - ) - (connections state) - <> FirstToFinish ( - NewConnection <$> InfoChannel.readMessage infoChannel - ) - <> FirstToFinish ( - -- spin the inbound governor loop; it will re-run with new - -- time, which allows to make some peers mature. - LazySTM.readTVar inactivityVar >>= check >> pure InactivityTimeout - ) - (mbConnId, state') <- case event of - NewConnection - -- new connection has been announced by either accept loop or - -- by connection manager (in which case the connection is in - -- 'DuplexState'). - (NewConnectionInfo - provenance - connId - dataFlow - Handle { - hMux = csMux, - hMuxBundle = muxBundle, - hVersionData = csVersionData - }) -> do - - traceWith tracer (TrNewConnection provenance connId) - let responderContext = ResponderContext { rcConnectionId = connId } - - connections <- Map.alterF - (\case - -- connection - Nothing -> do - let csMPMHot = - [ ( miniProtocolNum mpH - , MiniProtocolData mpH responderContext Hot - ) - | mpH <- projectBundle SingHot muxBundle - ] - csMPMWarm = - [ ( miniProtocolNum mpW - , MiniProtocolData mpW responderContext Warm - ) - | mpW <- projectBundle SingWarm muxBundle - ] - csMPMEstablished = - [ ( miniProtocolNum mpE - , MiniProtocolData mpE responderContext Established - ) - | mpE <- projectBundle SingEstablished muxBundle - ] - csMiniProtocolMap = - Map.fromList - (csMPMHot ++ csMPMWarm ++ csMPMEstablished) - - mCompletionMap - <- - foldM - (\acc mpd@MiniProtocolData { mpdMiniProtocol } -> - runResponder csMux mpd >>= \case - -- synchronous exceptions when starting - -- a mini-protocol are non-recoverable; we - -- close the connection and allow the server - -- to continue. - Left err -> do - traceWith tracer (TrResponderStartFailure connId (miniProtocolNum mpdMiniProtocol) err) - Mux.stop csMux - return Nothing - - Right completion -> do - let acc' = Map.insert (miniProtocolNum mpdMiniProtocol) - completion - <$> acc - -- force under lazy 'Maybe' - case acc' of - Just !_ -> return acc' - Nothing -> return acc' - ) - (Just Map.empty) - csMiniProtocolMap - - case mCompletionMap of - -- there was an error when starting one of the - -- responders, we let the server continue without this - -- connection. - Nothing -> return Nothing - - Just csCompletionMap -> do - mv <- traverse registerDelay idleTimeout - let -- initial state is 'RemoteIdle', if the remote end will not - -- start any responders this will unregister the inbound side. - csRemoteState :: RemoteState m - csRemoteState = RemoteIdle (case mv of - Nothing -> retry - Just v -> LazySTM.readTVar v >>= check) - - connState = ConnectionState { - csMux, - csVersionData, - csMiniProtocolMap, - csCompletionMap, - csRemoteState - } - - return (Just connState) - - -- inbound governor might be notified about a connection - -- which is already tracked. In such case we preserve its - -- state. - -- - -- In particular we preserve an ongoing timeout on - -- 'RemoteIdle' state. - Just connState -> return (Just connState) - - ) - connId - (connections state) - - time' <- getMonotonicTime - -- update state and continue the recursive loop - let state' = state { - connections, - freshDuplexPeers = - case dataFlow of - Unidirectional -> freshDuplexPeers state - Duplex -> OrdPSQ.insert (remoteAddress connId) time' csVersionData - (freshDuplexPeers state) - } - return (Just connId, state') - - MuxFinished connId merr -> do - - case merr of - Nothing -> traceWith tracer (TrMuxCleanExit connId) - Just err -> traceWith tracer (TrMuxErrored connId err) - - -- the connection manager does should realise this on itself. - let state' = unregisterConnection connId state - return (Just connId, state') - - MiniProtocolTerminated - Terminated { - tConnId, - tMux, - tMiniProtocolData = mpd@MiniProtocolData { mpdMiniProtocol = miniProtocol }, - tResult - } -> - let num = miniProtocolNum miniProtocol in - case tResult of - Left e -> do - -- a mini-protocol errored. In this case mux will shutdown, and - -- the connection manager will tear down the socket. We can just - -- forget the connection from 'State'. - traceWith tracer $ - TrResponderErrored tConnId num e - - let state' = unregisterConnection tConnId state - return (Just tConnId, state') - - Right _ -> - runResponder tMux mpd >>= \case - Right completionAction -> do - traceWith tracer (TrResponderRestarted tConnId num) - let state' = updateMiniProtocol tConnId num completionAction state - return (Nothing, state') - - Left err -> do - -- there is no way to recover from synchronous exceptions; we - -- stop mux which allows to close resources held by - -- connection manager. - traceWith tracer (TrResponderStartFailure tConnId num err) - Mux.stop tMux - - let state' = unregisterConnection tConnId state - - return (Just tConnId, state') - - - WaitIdleRemote connId -> do -- @ - -- DemotedToCold^{dataFlow}_{Remote} : InboundState Duplex - -- → InboundIdleState Duplex + -- PromotedToWarm^{Duplex}_{Remote} + -- @ + -- or + -- @ + -- Awake^{dataFlow}_{Remote} -- @ - -- NOTE: `demotedToColdRemote` doesn't throw, hence exception handling - -- is not needed. - res <- demotedToColdRemote connectionManager connId - traceWith tracer (TrWaitIdleRemote connId res) - case res of - TerminatedConnection {} -> do - let state' = unregisterConnection connId state - return (Just connId, state') - OperationSuccess {} -> do - mv <- traverse registerDelay idleTimeout - let timeoutSTM :: STM m () - !timeoutSTM = case mv of - Nothing -> retry - Just v -> LazySTM.readTVar v >>= check - - let state' = updateRemoteState connId (RemoteIdle timeoutSTM) state - - return (Just connId, state') - -- It could happen that the connection got deleted by connection - -- manager due to some async exception so we need to unregister it - -- from the inbound governor state. - UnsupportedState UnknownConnectionSt -> do - let state' = unregisterConnection connId state - return (Just connId, state') - UnsupportedState {} -> do - return (Just connId, state) - - -- @ - -- PromotedToWarm^{Duplex}_{Remote} - -- @ - -- or - -- @ - -- Awake^{dataFlow}_{Remote} - -- @ - -- - -- Note: the 'AwakeRemote' is detected as soon as mux detects any - -- traffic. This means that we'll observe this transition also if the - -- first message that arrives is terminating a mini-protocol. - AwakeRemote connId -> do - -- notify the connection manager about the transition -- - -- NOTE: `promotedToWarmRemote` doesn't throw, hence exception handling - -- is not needed. - res <- promotedToWarmRemote connectionManager connId - traceWith tracer (TrPromotedToWarmRemote connId res) - - case resultInState res of - UnknownConnectionSt -> do - let state' = unregisterConnection connId state - return (Just connId, state') - _ -> do - let state' = updateRemoteState - connId - RemoteWarm - state - return (Just connId, state') - - RemotePromotedToHot connId -> do - traceWith tracer (TrPromotedToHotRemote connId) - let state' = updateRemoteState connId RemoteHot state - - return (Just connId, state') - - RemoteDemotedToWarm connId -> do - traceWith tracer (TrDemotedToWarmRemote connId) - let state' = updateRemoteState connId RemoteWarm state - - return (Just connId, state') - - CommitRemote connId -> do - -- NOTE: `releaseInboundConnection` doesn't throw, hence exception - -- handling is not needed. - res <- releaseInboundConnection connectionManager connId - traceWith tracer $ TrDemotedToColdRemote connId res - case res of - UnsupportedState {} -> do - -- 'inState' can be either: - -- @'UnknownConnection'@, - -- @'InReservedOutboundState'@, - -- @'InUnnegotiatedState', - -- @'InOutboundState' 'Unidirectional'@, - -- @'InTerminatingState'@, - -- @'InTermiantedState'@. - let state' = unregisterConnection connId state - return (Just connId, state') - - TerminatedConnection {} -> do - -- 'inState' can be either: - -- @'InTerminatingState'@, - -- @'InTermiantedState'@. - let state' = unregisterConnection connId state - return (Just connId, state') - - OperationSuccess transition -> - case transition of - -- the following two cases are when the connection was not used - -- by p2p-governor, the connection will be closed. - CommitTr -> do + -- Note: the 'AwakeRemote' is detected as soon as mux detects any + -- traffic. This means that we'll observe this transition also if the + -- first message that arrives is terminating a mini-protocol. + AwakeRemote connId -> do + -- notify the connection manager about the transition + -- + -- NOTE: `promotedToWarmRemote` doesn't throw, hence exception handling + -- is not needed. + res <- promotedToWarmRemote connectionManager connId + traceWith tracer (TrPromotedToWarmRemote connId res) + + let state' = updateRemoteState + connId + RemoteWarm + state + return . Just $ StateWithPeerTransition state' connId + + RemotePromotedToHot connId -> do + traceWith tracer (TrPromotedToHotRemote connId) + let state' = updateRemoteState connId RemoteHot state + return . Just $ StateWithPeerTransition state' connId + + RemoteDemotedToWarm connId -> do + traceWith tracer (TrDemotedToWarmRemote connId) + let state' = updateRemoteState connId RemoteWarm state + return . Just $ StateWithPeerTransition state' connId + + CommitRemote connId -> do + -- NOTE: `releaseInboundConnection` doesn't throw, hence exception + -- handling is not needed. + res <- releaseInboundConnection connectionManager connId + traceWith tracer $ TrDemotedToColdRemote connId res + case res of + OperationSuccess transition -> + case transition of + -- the following two cases are when the connection was not used + -- by p2p-governor, the connection will be closed. + CommitTr -> do + -- @ + -- Commit^{dataFlow}_{Remote} : InboundIdleState dataFlow + -- → TerminatingState + -- @ + let state' = unregisterConnection False connId state + return . Just $ StateWithPeerTransition state' connId + + -- the connection is still used by p2p-governor, carry on but put + -- it in 'RemoteCold' state. This will ensure we keep ready to + -- serve the peer. -- @ - -- Commit^{dataFlow}_{Remote} : InboundIdleState dataFlow - -- → TerminatingState + -- DemotedToCold^{Duplex}_{Remote} : DuplexState + -- → OutboundState Duplex -- @ - let state' = unregisterConnection connId state - return (Just connId, state') - - -- the connection is still used by p2p-governor, carry on but put - -- it in 'RemoteCold' state. This will ensure we keep ready to - -- serve the peer. - -- @ - -- DemotedToCold^{Duplex}_{Remote} : DuplexState - -- → OutboundState Duplex - -- @ - -- or - -- @ - -- Awake^{Duplex}^{Local} : InboundIdleState Duplex - -- → OutboundState Duplex - -- @ - -- - -- note: the latter transition is level triggered rather than - -- edge triggered. The server state is updated once protocol - -- idleness expires rather than as soon as the connection - -- manager was requested outbound connection. - KeepTr -> do - let state' = updateRemoteState connId RemoteCold state - - return (Just connId, state') - - MaturedDuplexPeers newMatureDuplexPeers freshDuplexPeers -> do - traceWith tracer $ TrMaturedConnections (Map.keysSet newMatureDuplexPeers) - (Set.fromList $ OrdPSQ.keys freshDuplexPeers) - pure (Nothing, state { matureDuplexPeers = newMatureDuplexPeers - <> matureDuplexPeers state, - freshDuplexPeers }) - - InactivityTimeout -> do - traceWith tracer $ TrInactive ((\(a,b,_) -> (a,b)) <$> OrdPSQ.toList (freshDuplexPeers state)) - pure (Nothing, state) - - mask_ $ do - atomically $ writeTVar var (mkPublicState state') - traceWith debugTracer (Debug state') - case mbConnId of - Just cid -> traceWith trTracer (mkRemoteTransitionTrace cid state state') - Nothing -> pure () - - mapTraceWithCache TrInboundGovernorCounters - tracer - (countersCache state') - (counters state') - traceWith tracer $ TrRemoteState $ - mkRemoteSt . csRemoteState - <$> connections state' - - -- Update Inbound Governor Counters cache values - let newCounters = counters state' - Cache oldCounters = countersCache state' - state'' | newCounters /= oldCounters = state' { countersCache = Cache newCounters } - | otherwise = state' - - inboundGovernorLoop var state'' + -- or + -- @ + -- Awake^{Duplex}^{Local} : InboundIdleState Duplex + -- → OutboundState Duplex + -- @ + -- + -- note: the latter transition is level triggered rather than + -- edge triggered. The server state is updated once protocol + -- idleness expires rather than as soon as the connection + -- manager was requested outbound connection. + KeepTr -> do + let state' = updateRemoteState connId RemoteCold state + return . Just $ StateWithPeerTransition state' connId + + _otherwise -> return Nothing + + MaturedDuplexPeers newMatureDuplexPeers freshDuplexPeers -> do + traceWith tracer $ TrMaturedConnections (Map.keysSet newMatureDuplexPeers) + (Set.fromList $ OrdPSQ.keys freshDuplexPeers) + return . Just $ OnlyStateChange state { matureDuplexPeers = newMatureDuplexPeers + <> matureDuplexPeers state, + freshDuplexPeers } + + InactivityTimeout -> do + traceWith tracer $ TrInactive ((\(a,b,_) -> (a,b)) <$> OrdPSQ.toList (freshDuplexPeers state)) + return Nothing + + mask_ $ do + case decision of + Just (OnlyStateChange state') -> do + atomically $ writeTVar stateVar state' + traceWith debugTracer (Debug state') + Just (StateWithPeerTransition state' p) -> do + atomically $ writeTVar stateVar state' + traceWith debugTracer (Debug state') + traceWith trTracer (mkRemoteTransitionTrace p state state') + _otherwise -> pure () + + case decision of + _ | Just state' <- withState -> do + mapTraceWithCache TrInboundGovernorCounters + tracer + (countersCache state') + (counters state') + traceWith tracer $ TrRemoteState $ + mkRemoteSt . csRemoteState + <$> connections state' + + -- Update Inbound Governor Counters cache values + let newCounters = counters state' + Cache oldCounters = countersCache state' + state'' | newCounters /= oldCounters = state' { countersCache = Cache newCounters } + | otherwise = state' + + atomically $ writeTVar stateVar state'' + where + withState = case decision of + Just (OnlyStateChange s) -> Just s + Just (StateWithPeerTransition s _p) -> Just s + _otherwise -> Nothing + + _otherwise -> return () + +-- | The tracer embedded with the mux tracer by the connection handler +-- for inbound or outbound duplex connections for efficient tracking +-- of inbound governor transitions for a given peer +-- +inboundGovernorMuxTracer + :: (MonadSTM m, Ord peerAddr) + => InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData ByteString m a b + -> (versionData -> DataFlow) + -> StrictTVar m (State muxMode initiatorCtx peerAddr versionData m a b) + -> StrictTVar m Bool + -> StrictTVar m (StrictMaybe ResponderCounters) + -> Tracer m (Mux.WithBearer (ConnectionId peerAddr) Mux.Trace) +inboundGovernorMuxTracer infoChannel connectionDataFlow stateVar activeVar countersVar = + Tracer \(Mux.WithBearer peer trace) -> do + -- hello from muxer main thread + -- code here is running in the context of the connection handler/muxer + -- so care must be taken not to deadlock ourselves + active <- readTVarIO activeVar + case (trace, active) of + (_, True) | Just miniProtocolNum <- miniProtocolStarted trace -> atomically do + connections <- connections <$> readTVar stateVar + mCounters <- readTVar countersVar + case (Map.lookup peer connections, mCounters) of + (Just (ConnectionState { csRemoteState, csMiniProtocolMap }), + SJust rc@ResponderCounters { numTraceHotResponders, + numTraceNonHotResponders }) -> do + let miniProtocolTemp = getProtocolTemp miniProtocolNum csMiniProtocolMap + commit = do + case (numTraceNonHotResponders, numTraceHotResponders) of + (0, 0) -> InfoChannel.writeMessage infoChannel + (AwakeRemote peer) + _ -> pure () + case (miniProtocolTemp, numTraceHotResponders) of + (Hot, 0) -> InfoChannel.writeMessage infoChannel + (RemotePromotedToHot peer) + _ -> pure () + case miniProtocolTemp of + Hot -> writeTVar countersVar $ + SJust rc { numTraceHotResponders = + succ numTraceHotResponders } + _orNot -> writeTVar countersVar $ + SJust rc { numTraceNonHotResponders = + succ numTraceNonHotResponders } + + case csRemoteState of + -- we retry on expired because we let the IG + -- loop handle this peer. If the connection is released, + -- and CM reports CommitTr, this peer will disappear + -- from the connections so on retry we will hit the + -- _otherwise clause instead and promotion will fail, + -- as it should. Otherwise, if KeepTr is returned, + -- we can handle 'AwakeRemote' from this peer. + RemoteIdle timeoutSTM -> do + expired <- timeoutSTM + if expired then retry else commit + _ -> commit + + _otherwise -> writeTVar countersVar SNothing + + (_, True) | Just miniProtocolNum <- miniProtocolTerminated trace -> atomically do + connections <- connections <$> readTVar stateVar + mCounters <- readTVar countersVar + case (Map.lookup peer connections, mCounters) of + (Just (ConnectionState { csMux, + csVersionData, + csMiniProtocolMap, + csCompletionMap }), + SJust rc@ResponderCounters { numTraceHotResponders, + numTraceNonHotResponders }) -> do + InfoChannel.writeMessage infoChannel $ + MiniProtocolTerminated $ Terminated { + tConnId = peer, + tMux = csMux, + tMiniProtocolData = csMiniProtocolMap Map.! miniProtocolNum, + tDataFlow = connectionDataFlow csVersionData, + tResult = csCompletionMap Map.! miniProtocolNum } + case trace of + Mux.TraceCleanExit {} -> do + let miniProtocolTemp = getProtocolTemp miniProtocolNum csMiniProtocolMap + case (miniProtocolTemp, numTraceHotResponders) of + (Hot, 1) -> InfoChannel.writeMessage infoChannel + (RemoteDemotedToWarm peer) + _ -> pure () + when (numTraceHotResponders + numTraceNonHotResponders == 1) $ + InfoChannel.writeMessage infoChannel + (WaitIdleRemote peer) + case miniProtocolTemp of + Hot -> writeTVar countersVar $ + SJust rc { numTraceHotResponders = + pred numTraceHotResponders } + _orNot -> writeTVar countersVar $ + SJust rc { numTraceNonHotResponders = + pred numTraceNonHotResponders } + + _otherwise -> writeTVar countersVar SNothing + + _otherwise -> writeTVar countersVar SNothing + + + (_, True) | True <- muxStopped trace -> atomically do + State { connections } <- readTVar stateVar + case Map.lookup peer connections of + Just ConnectionState {csMux} -> + InfoChannel.writeMessage infoChannel $ + MuxFinished peer (Mux.stopped csMux) + _otherwise -> pure () + writeTVar countersVar SNothing + + _otherwise -> return () + where + muxStopped = \case + Mux.TraceStopped -> True + Mux.TraceState Mux.Dead -> True + _otherwise -> False + + getProtocolTemp miniProtocolNum csMiniProtocolMap = + let miniData = csMiniProtocolMap Map.! miniProtocolNum + in mpdMiniProtocolTemp miniData + + miniProtocolTerminated = \case + Mux.TraceCleanExit miniProtocolNum Mux.ResponderDir -> Just miniProtocolNum + Mux.TraceExceptionExit miniProtocolNum Mux.ResponderDir _e -> Just miniProtocolNum + _otherwise -> Nothing + + miniProtocolStarted = \case + -- is any responder started eagerly??? + Mux.TraceStartEagerly miniProtocolNum Mux.ResponderDir -> Just miniProtocolNum + Mux.TraceStartedOnDemand miniProtocolNum Mux.ResponderDir -> Just miniProtocolNum + _otherwise -> Nothing -- | Run a responder mini-protocol. @@ -646,6 +798,129 @@ mkRemoteTransitionTrace connId fromState toState = } +-- | A channel which instantiates to 'NewConnectionInfo' and +-- 'Handle'. +-- +-- * /Producer:/ connection manger for duplex outbound connections. +-- * /Consumer:/ inbound governor. +-- +type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData bytes m a b = + InformationChannel (Event (muxMode :: Mux.Mode) (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData bytes m a b) initiatorCtx peerAddr versionData m a b) m + + +-- | Announcement message for a new connection. +-- +data NewConnectionInfo peerAddr handle + + -- | Announce a new connection. /Inbound protocol governor/ will start + -- responder protocols using 'StartOnDemand' strategy and monitor remote + -- transitions: @PromotedToWarm^{Duplex}_{Remote}@ and + -- @DemotedToCold^{dataFlow}_{Remote}@. + = NewConnectionInfo + !Provenance + !(ConnectionId peerAddr) + !DataFlow + !handle + +instance Show peerAddr + => Show (NewConnectionInfo peerAddr handle) where + show (NewConnectionInfo provenance connId dataFlow _) = + concat [ "NewConnectionInfo " + , show provenance + , " " + , show connId + , " " + , show dataFlow + ] + + +-- | Edge triggered events to which the /inbound protocol governor/ reacts. +-- +data Event (muxMode :: Mux.Mode) handle initiatorCtx peerAddr versionData m a b + -- | A request to start mini-protocol bundle, either from the server or from + -- connection manager after a duplex connection was negotiated. + -- + = NewConnection !(NewConnectionInfo peerAddr handle) + + -- | A multiplexer exited. + -- + | MuxFinished !(ConnectionId peerAddr) (STM m (Maybe SomeException)) + + -- | A mini-protocol terminated either cleanly or abruptly. + -- + | MiniProtocolTerminated !(Terminated muxMode initiatorCtx peerAddr m a b) + + -- | Transition from 'RemoteEstablished' to 'RemoteIdle'. + -- + | WaitIdleRemote !(ConnectionId peerAddr) + + -- | A remote @warm → hot@ transition. It is scheduled as soon as all hot + -- mini-protocols are running. + -- + | RemotePromotedToHot !(ConnectionId peerAddr) + + -- | A @hot → warm@ transition. It is scheduled as soon as any hot + -- mini-protocol terminates. + -- + | RemoteDemotedToWarm !(ConnectionId peerAddr) + + -- | Transition from 'RemoteIdle' to 'RemoteCold'. + -- + | CommitRemote !(ConnectionId peerAddr) + + -- | Transition from 'RemoteIdle' or 'RemoteCold' to 'RemoteEstablished'. + -- + | AwakeRemote !(ConnectionId peerAddr) + + -- | Update `igsMatureDuplexPeers` and `igsFreshDuplexPeers`. + -- + | MaturedDuplexPeers !(Map peerAddr versionData) -- ^ newly matured duplex peers + !(OrdPSQ peerAddr Time versionData) -- ^ queue of fresh duplex peers + + | InactivityTimeout + + +-- STM transactions which detect 'Event's (signals) +-- + + +-- | A signal which returns an 'Event'. Signals are combined together and +-- passed used to fold the current state map. +-- +type EventSignal (muxMode :: Mux.Mode) handle initiatorCtx peerAddr versionData m a b = + ConnectionId peerAddr + -> ConnectionState muxMode initiatorCtx peerAddr versionData m a b + -> FirstToFinish (STM m) (Event muxMode handle initiatorCtx peerAddr versionData m a b) + + +-- | When a mini-protocol terminates we take 'Terminated' out of 'ConnectionState +-- and pass it to the main loop. This is just enough to decide if we need to +-- restart a mini-protocol and to do the restart. +-- +data Terminated muxMode initiatorCtx peerAddr m a b = Terminated { + tConnId :: !(ConnectionId peerAddr), + tMux :: !(Mux.Mux muxMode m), + tMiniProtocolData :: !(MiniProtocolData muxMode initiatorCtx peerAddr m a b), + tDataFlow :: !DataFlow, + tResult :: STM m (Either SomeException b) -- !(Either SomeException b) + } + + +-- | First peer for which the 'RemoteIdle' timeout expires. +-- +firstPeerCommitRemote :: (Alternative (STM m), MonadSTM m) + => EventSignal muxMode handle initiatorCtx peerAddr versionData m a b +firstPeerCommitRemote + connId ConnectionState { csRemoteState } + = case csRemoteState of + -- the connection is already in 'RemoteCold' state + RemoteCold -> mempty + RemoteEstablished -> mempty + RemoteIdle timeoutSTM -> FirstToFinish do + expired <- timeoutSTM + if expired then pure $ CommitRemote connId else retry + + data IGAssertionLocation peerAddr = InboundGovernorLoop !(Maybe (ConnectionId peerAddr)) !AbstractState deriving Show @@ -678,3 +953,6 @@ data Trace peerAddr data Debug peerAddr versionData = forall muxMode initiatorCtx m a b. Debug (State muxMode initiatorCtx peerAddr versionData m a b) + +data LoopDecision state peer = OnlyStateChange !state + | StateWithPeerTransition !state !peer diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs deleted file mode 100644 index 271325ed152..00000000000 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - --- Internals of inbound protocol governor. This module provide 'Event' type, --- which enumerates external events and stm action which block until these --- events fire. --- -module Ouroboros.Network.InboundGovernor.Event - ( Event (..) - , EventSignal - , firstMuxToFinish - , Terminated (..) - , firstMiniProtocolToFinish - , firstPeerPromotedToWarm - , firstPeerPromotedToHot - , firstPeerDemotedToWarm - , firstPeerDemotedToCold - , firstPeerCommitRemote - , NewConnectionInfo (..) - ) where - -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow hiding (handle) -import Control.Monad.Class.MonadTime.SI - -import Data.ByteString.Lazy (ByteString) -import Data.Functor (($>)) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Monoid.Synchronisation -import Data.OrdPSQ (OrdPSQ) -import Data.Set qualified as Set - -import Network.Mux qualified as Mux -import Network.Mux.Types (MiniProtocolDir (..), MiniProtocolStatus (..)) - -import Ouroboros.Network.ConnectionHandler -import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Context -import Ouroboros.Network.InboundGovernor.State -import Ouroboros.Network.Mux - - --- | Announcement message for a new connection. --- -data NewConnectionInfo peerAddr handle - - -- | Announce a new connection. /Inbound protocol governor/ will start - -- responder protocols using 'StartOnDemand' strategy and monitor remote - -- transitions: @PromotedToWarm^{Duplex}_{Remote}@ and - -- @DemotedToCold^{dataFlow}_{Remote}@. - = NewConnectionInfo - !Provenance - !(ConnectionId peerAddr) - !DataFlow - !handle - -instance Show peerAddr - => Show (NewConnectionInfo peerAddr handle) where - show (NewConnectionInfo provenance connId dataFlow _) = - concat [ "NewConnectionInfo " - , show provenance - , " " - , show connId - , " " - , show dataFlow - ] - --- | Edge triggered events to which the /inbound protocol governor/ reacts. --- -data Event (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b - -- | A request to start mini-protocol bundle, either from the server or from - -- connection manager after a duplex connection was negotiated. - -- - = NewConnection !(NewConnectionInfo peerAddr - (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData ByteString m a b)) - - -- | A multiplexer exited. - -- - | MuxFinished !(ConnectionId peerAddr) !(Maybe SomeException) - - -- | A mini-protocol terminated either cleanly or abruptly. - -- - | MiniProtocolTerminated !(Terminated muxMode initiatorCtx peerAddr m a b) - - -- | Transition from 'RemoteEstablished' to 'RemoteIdle'. - -- - | WaitIdleRemote !(ConnectionId peerAddr) - - -- | A remote @warm → hot@ transition. It is scheduled as soon as all hot - -- mini-protocols are running. - -- - | RemotePromotedToHot !(ConnectionId peerAddr) - - -- | A @hot → warm@ transition. It is scheduled as soon as any hot - -- mini-protocol terminates. - -- - | RemoteDemotedToWarm !(ConnectionId peerAddr) - - -- | Transition from 'RemoteIdle' to 'RemoteCold'. - -- - | CommitRemote !(ConnectionId peerAddr) - - -- | Transition from 'RemoteIdle' or 'RemoteCold' to 'RemoteEstablished'. - -- - | AwakeRemote !(ConnectionId peerAddr) - - -- | Update `igsMatureDuplexPeers` and `igsFreshDuplexPeers`. - -- - | MaturedDuplexPeers !(Map peerAddr versionData) -- ^ newly matured duplex peers - !(OrdPSQ peerAddr Time versionData) -- ^ queue of fresh duplex peers - - | InactivityTimeout - - --- --- STM transactions which detect 'Event's (signals) --- - - --- | A signal which returns an 'Event'. Signals are combined together and --- passed used to fold the current state map. --- -type EventSignal (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData m a b = - ConnectionId peerAddr - -> ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> FirstToFinish (STM m) (Event muxMode initiatorCtx peerAddr versionData m a b) - --- | A mux stopped. If mux exited cleanly no error is attached. --- -firstMuxToFinish :: MonadSTM m - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstMuxToFinish connId ConnectionState { csMux } = - FirstToFinish $ MuxFinished connId <$> Mux.stopped csMux - - --- | When a mini-protocol terminates we take 'Terminated' out of 'ConnectionState --- and pass it to the main loop. This is just enough to decide if we need to --- restart a mini-protocol and to do the restart. --- -data Terminated muxMode initiatorCtx peerAddr m a b = Terminated { - tConnId :: !(ConnectionId peerAddr), - tMux :: !(Mux.Mux muxMode m), - tMiniProtocolData :: !(MiniProtocolData muxMode initiatorCtx peerAddr m a b), - tDataFlow :: !DataFlow, - tResult :: !(Either SomeException b) - } - - --- | Detect when one of the mini-protocols terminated. --- --- /triggers:/ 'MiniProtocolTerminated'. --- -firstMiniProtocolToFinish :: Alternative (STM m) - => (versionData -> DataFlow) - -> EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstMiniProtocolToFinish - connDataFlow - connId - ConnectionState { csMux, - csVersionData, - csMiniProtocolMap, - csCompletionMap - } - = Map.foldMapWithKey - (\miniProtocolNum completionAction -> - (\tResult -> MiniProtocolTerminated $ Terminated { - tConnId = connId, - tMux = csMux, - tMiniProtocolData = csMiniProtocolMap Map.! miniProtocolNum, - tDataFlow = connDataFlow csVersionData, - tResult - } - ) - <$> FirstToFinish completionAction - ) - csCompletionMap - - --- | Detect when one of the peers was promoted to warm, e.g. --- @PromotedToWarm^{Duplex}_{Remote}@ or --- @PromotedToWarm^{Unidirectional}_{Remote}@. --- --- /triggers:/ 'PromotedToWarm' --- --- Note: The specification only describes @PromotedToWarm^{Duplex}_{Remote}@ --- transition, but here we don't make a distinction on @Duplex@ and --- @Unidirectional@ connections. --- -firstPeerPromotedToWarm :: forall muxMode initiatorCtx peerAddr versionData m a b. - ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerPromotedToWarm - connId - ConnectionState { csMux, csRemoteState } - = case csRemoteState of - -- the connection is already in 'RemoteEstablished' state. - RemoteEstablished -> mempty - - -- If the connection is in 'RemoteCold' state we do first to finish - -- synchronisation to detect incoming traffic on any of the responder - -- mini-protocols. - -- - -- This works for both duplex and unidirectional connections (e.g. p2p - -- \/ non-p2p nodes), for which protocols are started eagerly, unlike - -- for p2p nodes for which we start all mini-protocols on demand. - -- Using 'miniProtocolStatusVar' is ok for unidirectional connection, - -- as we never restart the protocols for them. They transition to - -- 'RemoteWarm' as soon the connection is accepted. This is because - -- for eagerly started mini-protocols mux puts them in 'StatusRunning' - -- as soon as mini-protocols are set in place by 'runMiniProtocol'. - RemoteCold -> - Map.foldMapWithKey - fn - (Mux.miniProtocolStateMap csMux) - - -- We skip it here; this case is done in 'firstPeerDemotedToCold'. - RemoteIdle {} -> - Map.foldMapWithKey - fn - (Mux.miniProtocolStateMap csMux) - where - fn :: (MiniProtocolNum, MiniProtocolDir) - -> STM m MiniProtocolStatus - -> FirstToFinish (STM m) (Event muxMode initiatorCtx peerAddr versionData m a b) - fn = \(_miniProtocolNum, miniProtocolDir) miniProtocolStatus -> - case miniProtocolDir of - InitiatorDir -> mempty - - ResponderDir -> - FirstToFinish $ - miniProtocolStatus >>= \case - StatusIdle -> retry - StatusStartOnDemand -> retry - StatusStartOnDemandAny -> retry - StatusRunning -> return $ AwakeRemote connId - - --- | Detect when a first warm peer is promoted to hot (any hot mini-protocols --- is running). --- -firstPeerPromotedToHot :: forall muxMode initiatorCtx peerAddr versionData m a b. - ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerPromotedToHot - connId connState@ConnectionState { csRemoteState } - = case csRemoteState of - RemoteHot -> mempty - RemoteWarm -> - fmap (const $ RemotePromotedToHot connId) - $ foldMap fn - (hotMiniProtocolStateMap connState) - RemoteCold -> - fmap (const $ RemotePromotedToHot connId) - $ foldMap fn - (hotMiniProtocolStateMap connState) - RemoteIdle {} -> mempty - where - -- only hot mini-protocols; - hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> Map (MiniProtocolNum, MiniProtocolDir) - (STM m MiniProtocolStatus) - hotMiniProtocolStateMap ConnectionState { csMux, csMiniProtocolMap } = - Mux.miniProtocolStateMap csMux - `Map.restrictKeys` - ( Set.map (,ResponderDir) - . Map.keysSet - . Map.filter - (\MiniProtocolData { mpdMiniProtocolTemp } -> - case mpdMiniProtocolTemp of - Hot -> True - _ -> False - ) - $ csMiniProtocolMap - ) - - fn :: STM m MiniProtocolStatus - -> FirstToFinish (STM m) () - fn miniProtocolStatus = - FirstToFinish $ - miniProtocolStatus >>= \case - StatusIdle -> retry - StatusStartOnDemand -> retry - StatusStartOnDemandAny -> retry - StatusRunning -> return () - - --- | Detect when all hot mini-protocols terminates, which triggers the --- `RemoteHot → RemoteWarm` transition. --- -firstPeerDemotedToWarm :: forall muxMode initiatorCtx peerAddr versionData m a b. - ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerDemotedToWarm - connId connState@ConnectionState { csRemoteState } - = case csRemoteState of - RemoteHot -> - lastToFirstM $ - RemoteDemotedToWarm connId <$ foldMap fn (hotMiniProtocolStateMap connState) - - _ -> mempty - where - -- only hot mini-protocols; - hotMiniProtocolStateMap :: ConnectionState muxMode initiatorCtx peerAddr versionData m a b - -> Map (MiniProtocolNum, MiniProtocolDir) - (STM m MiniProtocolStatus) - hotMiniProtocolStateMap ConnectionState { csMux, csMiniProtocolMap } = - Mux.miniProtocolStateMap csMux - `Map.restrictKeys` - ( Set.map (,ResponderDir) - . Map.keysSet - . Map.filter - (\MiniProtocolData { mpdMiniProtocolTemp } -> - case mpdMiniProtocolTemp of - Hot -> True - _ -> False - ) - $ csMiniProtocolMap - ) - - fn :: STM m MiniProtocolStatus - -> LastToFinishM (STM m) () - fn miniProtocolStatus = - LastToFinishM $ - miniProtocolStatus >>= \case - StatusIdle -> return () - StatusStartOnDemand -> return () - StatusStartOnDemandAny -> return () - StatusRunning -> retry - - --- | Await for first peer demoted to cold, i.e. detect the --- @DemotedToCold^{Duplex}_{Remote}@. --- --- /triggers:/ 'DemotedToColdRemote' --- -firstPeerDemotedToCold :: ( Alternative (STM m) - , MonadSTM m - ) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerDemotedToCold - connId - ConnectionState { - csMux, - csRemoteState - } - = case csRemoteState of - -- the connection is already in 'RemoteCold' state - RemoteCold -> mempty - - -- Responders are started using 'StartOnDemand' strategy. We detect - -- when all of the responders are in 'StatusIdle' or - -- 'StatusStartOnDemand' and subsequently put the connection in - -- 'RemoteIdle' state. - -- - -- In compat mode, when established mini-protocols terminate they will - -- not be restarted. - RemoteEstablished -> - fmap (const $ WaitIdleRemote connId) - . lastToFirstM - $ Map.foldMapWithKey - (\(_, miniProtocolDir) miniProtocolStatus -> - case miniProtocolDir of - InitiatorDir -> mempty - - ResponderDir -> - LastToFinishM $ do - miniProtocolStatus >>= \case - StatusIdle -> return () - StatusStartOnDemand -> return () - StatusStartOnDemandAny -> return () - StatusRunning -> retry - ) - (Mux.miniProtocolStateMap csMux) - - RemoteIdle {} -> mempty - - --- | First peer for which the 'RemoteIdle' timeout expires. --- -firstPeerCommitRemote :: Alternative (STM m) - => EventSignal muxMode initiatorCtx peerAddr versionData m a b -firstPeerCommitRemote - connId ConnectionState { csRemoteState } - = case csRemoteState of - -- the connection is already in 'RemoteCold' state - RemoteCold -> mempty - RemoteEstablished -> mempty - RemoteIdle timeoutSTM -> FirstToFinish (timeoutSTM $> CommitRemote connId) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/InformationChannel.hs similarity index 56% rename from ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs rename to ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/InformationChannel.hs index a133382ec4c..ae59d1df606 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/InformationChannel.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/InformationChannel.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} -module Ouroboros.Network.ConnectionManager.InformationChannel + +module Ouroboros.Network.InboundGovernor.InformationChannel ( InformationChannel (..) - , InboundGovernorInfoChannel , newInformationChannel ) where @@ -11,10 +12,6 @@ import Control.Concurrent.Class.MonadSTM.Strict import Data.Functor (($>)) import GHC.Natural (Natural) -import Network.Mux qualified as Mux -import Ouroboros.Network.ConnectionHandler (Handle) -import Ouroboros.Network.Context (ResponderContext) -import Ouroboros.Network.InboundGovernor.Event (NewConnectionInfo) -- | Information channel. -- @@ -24,20 +21,16 @@ data InformationChannel a m = -- readMessage :: STM m a, + -- | Efficiently flush all values from the channel + -- for batch processing + -- + readMessages :: STM m [a], + -- | Write a value to the channel. -- writeMessage :: a -> STM m () } --- | A channel which instantiates to 'NewConnectionInfo' and --- 'Handle'. --- --- * /Producer:/ connection manger for duplex outbound connections. --- * /Consumer:/ inbound governor. --- -type InboundGovernorInfoChannel (muxMode :: Mux.Mode) initiatorCtx peerAddr versionData bytes m a b = - InformationChannel (NewConnectionInfo peerAddr (Handle muxMode initiatorCtx (ResponderContext peerAddr) versionData bytes m a b)) m - -- | Create a new 'InformationChannel' backed by a `TBQueue`. -- @@ -50,11 +43,12 @@ newInformationChannel = do >>= \q -> labelTBQueue q "server-cc" $> q pure $ InformationChannel { readMessage = readTBQueue channel, - writeMessage = writeTBQueue channel + readMessages = flushTBQueue channel, + writeMessage = \(!a) -> writeTBQueue channel a } -- | The 'InformationChannel's 'TBQueue' depth. -- cc_QUEUE_BOUND :: Natural -cc_QUEUE_BOUND = 10 +cc_QUEUE_BOUND = 100 diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs index 445ff4f812f..3ec04788d51 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/State.hs @@ -15,6 +15,7 @@ module Ouroboros.Network.InboundGovernor.State , mkPublicState , State (..) , ConnectionState (..) + , ResponderCounters (..) , Counters (..) , counters , unregisterConnection @@ -186,9 +187,16 @@ data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = Connectio -- | State of the connection. -- csRemoteState :: !(RemoteState m) - } +-- | The IG maintains a state of the number of hot and warm +-- miniprotocol responders to track transitions and notify +-- the connection manager for interesting events. +-- +data ResponderCounters = ResponderCounters { + numTraceHotResponders :: !Int, + numTraceNonHotResponders :: !Int + } -- -- State management functions @@ -198,12 +206,13 @@ data ConnectionState muxMode initiatorCtx peerAddr versionData m a b = Connectio -- | Remove connection from 'State'. -- unregisterConnection :: Ord peerAddr - => ConnectionId peerAddr + => Bool + -> ConnectionId peerAddr -> State muxMode initiatorCtx peerAddr versionData m a b -> State muxMode initiatorCtx peerAddr versionData m a b -unregisterConnection connId state = +unregisterConnection bypass connId state = state { connections = - assert (connId `Map.member` connections state) $ + assert (connId `Map.member` connections state || bypass) $ Map.delete connId (connections state), matureDuplexPeers = @@ -259,11 +268,11 @@ data RemoteState m -- | After @DemotedToCold^{dataFlow}_{Remote}@ is detected. This state -- corresponds to 'InboundIdleState'. In this state we are checking -- if the responder protocols are idle during protocol idle timeout - -- (represented by an 'STM' action) + -- (represented by an 'STM' with a boolean representing expired timeout state) -- -- 'RemoteIdle' is the initial state of an accepted a connection. -- - | RemoteIdle !(STM m ()) + | RemoteIdle !(STM m Bool) -- | The 'RemoteCold' state for 'Duplex' connections allows us to have -- responders started using the on-demand strategy. This assures that once diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs index 81fa7e128ba..dfa9d9da02a 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -37,9 +38,10 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow hiding (handle) import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI +import Control.Monad.Fix (MonadFix) + import Control.Tracer (Tracer, contramap, traceWith) -import Data.ByteString.Lazy (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (isNothing) @@ -49,13 +51,8 @@ import GHC.IO.Exception import Foreign.C.Error #endif -import Network.Mux qualified as Mx -import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.ConnectionManager.InformationChannel - (InboundGovernorInfoChannel) import Ouroboros.Network.ConnectionManager.Types -import Ouroboros.Network.Context (ResponderContext) import Ouroboros.Network.InboundGovernor qualified as InboundGovernor import Ouroboros.Network.Mux import Ouroboros.Network.Server.RateLimiting @@ -69,31 +66,13 @@ import Ouroboros.Network.Snocket -- | Server static configuration. -- -data Arguments (muxMode :: Mx.Mode) socket initiatorCtx peerAddr versionData versionNumber bytes m a b = +data Arguments muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace handleError versionNumber versionData bytes m a b x = Arguments { sockets :: NonEmpty socket, snocket :: Snocket m socket peerAddr, tracer :: Tracer m (Trace peerAddr), - trTracer :: Tracer m (InboundGovernor.RemoteTransitionTrace peerAddr), - inboundGovernorTracer :: Tracer m (InboundGovernor.Trace peerAddr), - debugInboundGovernor :: Tracer m (InboundGovernor.Debug peerAddr versionData), connectionLimits :: AcceptedConnectionsLimit, - connectionManager :: MuxConnectionManager muxMode socket initiatorCtx (ResponderContext peerAddr) - peerAddr versionData versionNumber bytes m a b, - - -- | Time for which all protocols need to be idle to trigger - -- 'DemotedToCold' transition. - -- - inboundIdleTimeout :: Maybe DiffTime, - - connectionDataFlow :: versionData -> DataFlow, - - -- | Server control var is passed as an argument; this allows to use the - -- server to run and manage responders which needs to be started on - -- inbound connections. - -- - inboundInfoChannel :: InboundGovernorInfoChannel muxMode initiatorCtx peerAddr versionData - bytes m a b + inboundGovernorArgs :: InboundGovernor.Arguments muxMode handlerTrace socket peerAddr initiatorCtx responderCtx handle handleError versionNumber versionData bytes m a b x } -- | Server pauses accepting connections after an 'CONNABORTED' error. @@ -116,7 +95,7 @@ server_CONNABORTED_DELAY = 0.5 -- The first one is used in data diffusion for /Node-To-Node protocol/, while the -- other is useful for running a server for the /Node-To-Client protocol/. -- -with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m a b x. +with :: forall muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace handleError versionNumber versionData bytes m a b x. ( Alternative (STM m) , MonadAsync m , MonadDelay m @@ -130,10 +109,18 @@ with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m , HasResponder muxMode ~ True , Ord peerAddr , Show peerAddr + , MonadTraceSTM m + , MonadFork m + , MonadFix m ) - => Arguments muxMode socket initiatorCtx peerAddr versionData versionNumber ByteString m a b + => Arguments muxMode socket peerAddr initiatorCtx responderCtx handle handlerTrace + handleError versionNumber versionData bytes m a b x -- ^ record which holds all server arguments - -> (Async m Void -> m (InboundGovernor.PublicState peerAddr versionData) -> m x) + -> ( Async m Void + -> m (InboundGovernor.PublicState peerAddr versionData) + -> ConnectionManager + muxMode socket peerAddr handle handleError m + -> m x) -- ^ a callback which receives a handle to inbound governor thread and can -- read `PublicState`. -- @@ -143,56 +130,44 @@ with :: forall muxMode socket initiatorCtx peerAddr versionData versionNumber m with Arguments { sockets = socks, snocket, - trTracer, - tracer = tracer, - inboundGovernorTracer = inboundGovernorTracer, - debugInboundGovernor, + tracer, connectionLimits = limits@AcceptedConnectionsLimit { acceptedConnectionsHardLimit = hardLimit }, - inboundIdleTimeout, - connectionManager, - connectionDataFlow, - inboundInfoChannel + inboundGovernorArgs } - k = do + k + = do let sockets = NonEmpty.toList socks localAddresses <- traverse (getLocalAddr snocket) sockets - traceWith tracer (TrServerStarted localAddresses) - InboundGovernor.with - InboundGovernor.Arguments { - InboundGovernor.transitionTracer = trTracer, - InboundGovernor.tracer = inboundGovernorTracer, - InboundGovernor.debugTracer = debugInboundGovernor, - InboundGovernor.connectionDataFlow = connectionDataFlow, - InboundGovernor.infoChannel = inboundInfoChannel, - InboundGovernor.idleTimeout = inboundIdleTimeout, - InboundGovernor.connectionManager = connectionManager - } $ \inboundGovernorThread readPublicInboundState -> - withAsync (do - labelThisThread "Server2 (ouroboros-network-framework)" - k inboundGovernorThread readPublicInboundState) $ \actionThread -> do - let acceptLoops :: [m Void] - acceptLoops = - [ (do - labelThisThread ("accept " ++ show localAddress) - accept snocket socket >>= acceptLoop localAddress) - `finally` close snocket socket - | (localAddress, socket) <- localAddresses `zip` sockets - ] - -- race all `acceptLoops` with `actionThread` and - -- `inboundGovernorThread` - let waiter = fn <$> (do - labelThisThread "racing-action-inbound-governor" - actionThread `waitEither` inboundGovernorThread) + InboundGovernor.with inboundGovernorArgs + \inboundGovernorThread readPublicInboundState connectionManager -> + withAsync do + labelThisThread "Server2 (ouroboros-network-framework)" + k inboundGovernorThread readPublicInboundState connectionManager + \actionThread -> do + traceWith tracer (TrServerStarted localAddresses) + let acceptLoops :: [m Void] + acceptLoops = + [ (do + labelThisThread ("accept " ++ show localAddress) + accept snocket socket >>= acceptLoop localAddress connectionManager) + `finally` close snocket socket + | (localAddress, socket) <- localAddresses `zip` sockets + ] + -- race all `acceptLoops` with `actionThread` and + -- `inboundGovernorThread` + let waiter = fn <$> (do + labelThisThread "racing-action-inbound-governor" + actionThread `waitEither` inboundGovernorThread) - (fn <$> waiter `race` (labelThisThread "racing-accept-loops" >> raceAll acceptLoops)) - `finally` - traceWith tracer TrServerStopped - `catch` - \(e :: SomeException) -> do - when (isNothing $ fromException @SomeAsyncException e) $ - traceWith tracer (TrServerError e) - throwIO e + (fn <$> waiter `race` (labelThisThread "racing-accept-loops" >> raceAll acceptLoops)) + `finally` + traceWith tracer TrServerStopped + `catch` + \(e :: SomeException) -> do + when (isNothing $ fromException @SomeAsyncException e) $ + traceWith tracer (TrServerError e) + throwIO e where fn :: Either x Void -> x fn (Left x) = x @@ -206,9 +181,10 @@ with Arguments { go as (x:xs) = withAsync x (\a -> go (a:as) xs) acceptLoop :: peerAddr + -> ConnectionManager muxMode socket peerAddr handle handleError m -> Accept m socket peerAddr -> m Void - acceptLoop localAddress acceptOne0 = mask $ \unmask -> do + acceptLoop localAddress connectionManager acceptOne0 = mask $ \unmask -> do labelThisThread ("accept-loop-" ++ show localAddress) go unmask acceptOne0 where diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs index bbdbadd3ee1..a59988fe70d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/Simple.hs @@ -85,7 +85,7 @@ with sn makeBearer configureSock addr handshakeArgs versions k = 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 + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) mux bearer) $ \aid -> do void $ simpleMuxCallback connId vNumber vData app mux aid errorHandler = \e -> throwIO e diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index f9dcc241474..e4b322cbf9d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -409,7 +409,7 @@ connectToNodeWithMux' Mx.withReadBufferIO (\buffer -> do bearer <- Mx.getBearer makeBearer sduTimeout muxTracer sd buffer mux <- Mx.new (toMiniProtocolInfos (runForkPolicy noBindForkPolicy remoteAddress) app) - withAsync (Mx.run muxTracer mux bearer) $ \aid -> + withAsync (Mx.run (Mx.Tracers muxTracer muxTracer) mux bearer) $ \aid -> k connectionId versionNumber agreedOptions app mux aid ) @@ -502,4 +502,3 @@ data SomeResponderApplication addr bytes m b where Mx.HasResponder muxMode ~ True => (OuroborosApplicationWithMinimalCtx muxMode addr bytes m a b) -> SomeResponderApplication addr bytes m b - diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index c1fc4a26977..dde99502369 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -82,6 +84,8 @@ import Ouroboros.Network.Context import Ouroboros.Network.ControlMessage import Ouroboros.Network.Driver.Limits import Ouroboros.Network.InboundGovernor qualified as InboundGovernor +import Ouroboros.Network.InboundGovernor.InformationChannel + (newInformationChannel) import Ouroboros.Network.Mux import Ouroboros.Network.MuxMode import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) @@ -103,9 +107,6 @@ import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.Orphans () import Test.Ouroboros.Network.Utils (WithName (..)) -import Ouroboros.Network.ConnectionManager.InformationChannel - (newInformationChannel) - -- -- Server tests @@ -276,55 +277,58 @@ withInitiatorOnlyConnectionManager -> m a withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket makeBearer connStateIdSupply localAddr nextRequests handshakeTimeLimits acceptedConnLimit k = do - mainThreadId <- myThreadId - let muxTracer = (name,) `contramap` nullTracer -- mux tracer - CM.with - CM.Arguments { - -- ConnectionManagerTrace - CM.tracer = WithName name - `contramap` tracer, - CM.trTracer = (WithName name . fmap CM.abstractState) - `contramap` trTracer, - -- MuxTracer - CM.muxTracer = muxTracer, - CM.ipv4Address = localAddr, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \_ _ -> return (), - CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen, - CM.connectionsLimits = acceptedConnLimit, - CM.timeWaitTimeout = tTimeWaitTimeout timeouts, - CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts, - CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply - } - (makeConnectionHandler - muxTracer - SingInitiatorMode - noBindForkPolicy - HandshakeArguments { - -- TraceSendRecv - haHandshakeTracer = (name,) `contramap` nullTracer, - haHandshakeCodec = unversionedHandshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = handshakeTimeLimits - } - (dataFlowProtocol Unidirectional clientApplication) - (mainThreadId, debugMuxErrorRethrowPolicy - <> debugMuxRuntimeErrorRethrowPolicy - <> debugIOErrorRethrowPolicy - <> assertRethrowPolicy)) - (\_ -> HandshakeFailure) - NotInResponderMode - (\cm -> - k cm `catch` \(e :: SomeException) -> throwIO e) + mainThreadId <- myThreadId + let muxTracer = (name,) `contramap` nullTracer -- mux tracer + mkConnectionHandler = + makeConnectionHandler + muxTracer + noBindForkPolicy + HandshakeArguments { + -- TraceSendRecv + haHandshakeTracer = WithName name `contramap` nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = handshakeTimeLimits + } + (dataFlowProtocol Unidirectional clientApplication) + (mainThreadId, debugMuxErrorRethrowPolicy + <> debugMuxRuntimeErrorRethrowPolicy + <> debugIOErrorRethrowPolicy + <> assertRethrowPolicy) + MuxInitiatorConnectionHandler + + + CM.with CM.Arguments { + -- ConnectionManagerTrace + tracer = WithName name + `contramap` tracer, + trTracer = (WithName name . fmap CM.abstractState) + `contramap` trTracer, + -- This is actually the low level bearer tracer + muxTracer = nullTracer, + ipv4Address = localAddr, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket, + makeBearer, + withBuffer = \f -> f Nothing, + configureSocket = \_ _ -> return (), + connectionDataFlow = \(DataFlowProtocolData df _) -> df, + timeWaitTimeout = tTimeWaitTimeout timeouts, + outboundIdleTimeout = tOutboundIdleTimeout timeouts, + prunePolicy = simplePrunePolicy, + stdGen, + connectionsLimits = acceptedConnLimit, + updateVersionData = \a _ -> a, + connStateIdSupply, + classifyHandleError = \_ -> HandshakeFailure + } + NotInResponderMode + mkConnectionHandler + \cm -> + k cm `catch` \(e :: SomeException) -> throwIO e where clientApplication :: TemperatureBundle [MiniProtocol Mx.InitiatorMode @@ -432,6 +436,7 @@ withBidirectionalConnectionManager peerAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) -> Tracer m (WithName name (InboundGovernor.Trace peerAddr)) + -> Tracer m (WithName name (Mx.WithBearer (ConnectionId peerAddr) Mx.Trace)) -> Tracer m (WithName name (InboundGovernor.Debug peerAddr DataFlowProtocolData)) -> StdGen -> Snocket m socket peerAddr @@ -459,7 +464,7 @@ withBidirectionalConnectionManager -> m a withBidirectionalConnectionManager name timeouts inboundTrTracer trTracer - tracer inboundTracer debugTracer + tracer inboundTracer muxTracer debugTracer stdGen snocket makeBearer connStateIdSupply confSock socket @@ -469,82 +474,86 @@ withBidirectionalConnectionManager name timeouts acceptedConnLimit k = do mainThreadId <- myThreadId inbgovInfoChannel <- newInformationChannel - let muxTracer = WithName name `contramap` nullTracer -- mux tracer - - CM.with - CM.Arguments { - -- ConnectionManagerTrace - CM.tracer = WithName name - `contramap` tracer, - CM.trTracer = (WithName name . fmap CM.abstractState) - `contramap` trTracer, - -- MuxTracer - CM.muxTracer = muxTracer, - CM.ipv4Address = localAddress, - CM.ipv6Address = Nothing, - CM.addressType = \_ -> Just IPv4Address, - CM.snocket = snocket, - CM.makeBearer = makeBearer, - CM.withBuffer = \f -> f Nothing, - CM.configureSocket = \sock _ -> confSock sock, - CM.timeWaitTimeout = tTimeWaitTimeout timeouts, - CM.outboundIdleTimeout = tOutboundIdleTimeout timeouts, - CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, - CM.prunePolicy = simplePrunePolicy, - CM.stdGen, - CM.connectionsLimits = acceptedConnLimit, - CM.updateVersionData = \versionData diffusionMode -> + let mkConnectionHandler = + makeConnectionHandler + (WithName name `contramap` muxTracer) + noBindForkPolicy + HandshakeArguments { + -- TraceSendRecv + haHandshakeTracer = WithName name `contramap` nullTracer, + haHandshakeCodec = unversionedHandshakeCodec, + haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = handshakeTimeLimits + } + (dataFlowProtocol Duplex serverApplication) + (mainThreadId, debugMuxErrorRethrowPolicy + <> debugMuxRuntimeErrorRethrowPolicy + <> debugIOErrorRethrowPolicy + <> assertRethrowPolicy) + + withConnectionManager connectionHandler k' = + CM.with CM.Arguments { + -- ConnectionManagerTrace + tracer = WithName name + `contramap` tracer, + trTracer = (WithName name . fmap CM.abstractState) + `contramap` trTracer, + -- low level bearer tracer + muxTracer = WithName name `contramap` nullTracer, --muxTracer, + ipv4Address = localAddress, + ipv6Address = Nothing, + addressType = \_ -> Just IPv4Address, + snocket, + makeBearer, + withBuffer = \f -> f Nothing, + configureSocket = \sock _ -> confSock sock, + connectionDataFlow = \(DataFlowProtocolData df _) -> df, + timeWaitTimeout = tTimeWaitTimeout timeouts, + outboundIdleTimeout = tOutboundIdleTimeout timeouts, + -- CM.connectionDataFlow = \(DataFlowProtocolData df _) -> df, + prunePolicy = simplePrunePolicy, + stdGen, + connectionsLimits = acceptedConnLimit, + updateVersionData = \versionData diffusionMode -> versionData { getProtocolDataFlow = case diffusionMode of InitiatorOnlyDiffusionMode -> Unidirectional InitiatorAndResponderDiffusionMode -> Duplex }, - CM.connStateIdSupply - } - (makeConnectionHandler - muxTracer - SingInitiatorResponderMode - noBindForkPolicy - HandshakeArguments { - -- TraceSendRecv - haHandshakeTracer = WithName name `contramap` nullTracer, - haHandshakeCodec = unversionedHandshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, - haAcceptVersion = acceptableVersion, - haQueryVersion = queryVersion, - haTimeLimits = handshakeTimeLimits + connStateIdSupply, + classifyHandleError = (\_ -> HandshakeFailure) } - (dataFlowProtocol Duplex serverApplication) - (mainThreadId, debugMuxErrorRethrowPolicy - <> debugMuxRuntimeErrorRethrowPolicy - <> debugIOErrorRethrowPolicy - <> assertRethrowPolicy)) - (\_ -> HandshakeFailure) - (InResponderMode inbgovInfoChannel) - $ \connectionManager -> - do - serverAddr <- Snocket.getLocalAddr snocket socket - Server.with - Server.Arguments { - Server.sockets = socket :| [], - Server.snocket = snocket, - Server.trTracer = - WithName name `contramap` inboundTrTracer, - Server.tracer = - WithName name `contramap` nullTracer, -- ServerTrace - Server.debugInboundGovernor = - WithName name `contramap` debugTracer, - Server.inboundGovernorTracer = - WithName name `contramap` inboundTracer, -- InboundGovernorTrace - Server.connectionLimits = acceptedConnLimit, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = \(DataFlowProtocolData df _) -> df, - Server.inboundIdleTimeout = Just (tProtocolIdleTimeout timeouts), - Server.inboundInfoChannel = inbgovInfoChannel - } - (\inboundGovernorAsync _ -> k connectionManager serverAddr inboundGovernorAsync) - `catch` \(e :: SomeException) -> do - throwIO e + (InResponderMode inbgovInfoChannel) + connectionHandler + k' + + serverAddr <- Snocket.getLocalAddr snocket socket + handle (\(e :: SomeException) -> throwIO e) $ + Server.with + Server.Arguments { + sockets = socket :| [], + snocket = snocket, + tracer = + WithName name `contramap` nullTracer, -- ServerTrace + connectionLimits = acceptedConnLimit, + inboundGovernorArgs = + InboundGovernor.Arguments { + transitionTracer = + WithName name `contramap` inboundTrTracer, + tracer = + WithName name `contramap` inboundTracer, -- InboundGovernorTrace + debugTracer = + WithName name `contramap` debugTracer, + connectionDataFlow = \(DataFlowProtocolData df _) -> df, + infoChannel = inbgovInfoChannel, + idleTimeout = Just (tProtocolIdleTimeout timeouts), + withConnectionManager, + mkConnectionHandler = mkConnectionHandler . MuxInitiatorResponderConnectionHandler (\(DataFlowProtocolData df _) -> df) + } + } + (\inboundGovernorAsync _ connectionManager -> k connectionManager serverAddr inboundGovernorAsync) where serverApplication :: TemperatureBundle [MiniProtocol Mx.InitiatorResponderMode @@ -743,7 +752,7 @@ unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clie $ \connectionManager -> withBidirectionalConnectionManager "server" timeouts nullTracer nullTracer nullTracer - nullTracer nullTracer + nullTracer nullTracer nullTracer stdGen'' snocket makeBearer connStateIdSupply confSock socket Nothing @@ -827,7 +836,7 @@ bidirectionalExperiment nextRequests0 <- oneshotNextRequests clientAndServerData0 nextRequests1 <- oneshotNextRequests clientAndServerData1 withBidirectionalConnectionManager "node-0" timeouts - nullTracer nullTracer nullTracer nullTracer + nullTracer nullTracer nullTracer nullTracer nullTracer nullTracer stdGen' snocket makeBearer connStateIdSupply confSock socket0 (Just localAddr0) @@ -837,7 +846,7 @@ bidirectionalExperiment maxAcceptedConnectionsLimit (\connectionManager0 _serverAddr0 _serverAsync0 -> do withBidirectionalConnectionManager "node-1" timeouts - nullTracer nullTracer nullTracer nullTracer + nullTracer nullTracer nullTracer nullTracer nullTracer nullTracer stdGen'' snocket makeBearer connStateIdSupply confSock socket1 (Just localAddr1) @@ -931,19 +940,6 @@ bidirectionalExperiment -- Utils -- - --- | Redefine this tracer to get valuable tracing information from various --- components: --- --- * connection-manager --- * inbound governor --- * server --- --- debugTracer :: (MonadSay m, MonadTime m, Show a) => Tracer m a --- debugTracer = Tracer (\msg -> (,msg) <$> getCurrentTime >>= say . show) - -- <> Tracer Debug.traceShowM - - withLock :: ( MonadSTM m , MonadThrow m ) diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs index 119b3def13e..4ead5bca415 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Utils.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Test.Ouroboros.Network.Utils ( -- * Arbitrary Delays @@ -30,6 +31,7 @@ module Test.Ouroboros.Network.Utils , splitWithNameTrace -- * Tracers , debugTracer + , debugTracerG , sayTracer -- * Tasty Utils , nightlyTest @@ -38,8 +40,11 @@ module Test.Ouroboros.Network.Utils , renderRanges ) where +import GHC.Real + import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadTime.SI +import Control.Monad.IOSim (IOSim, traceM) import Control.Tracer (Contravariant (contramap), Tracer (..), contramapM) import Data.Bitraversable (bimapAccumR) @@ -48,9 +53,9 @@ import Data.List.Trace (Trace) import Data.List.Trace qualified as Trace import Data.Map qualified as Map import Data.Maybe (fromJust, isJust) -import Data.Ratio import Data.Set (Set) import Data.Set qualified as Set +import Data.Typeable (Typeable) import Text.Pretty.Simple (pPrint) import Debug.Trace (traceShowM) @@ -61,7 +66,7 @@ import Test.Tasty.ExpectedFailure (ignoreTest) newtype Delay = Delay { getDelay :: DiffTime } deriving Show - deriving newtype (Eq, Ord, Num) + deriving newtype (Eq, Ord, Num, Fractional, Real) genDelayWithPrecision :: Integer -> Gen DiffTime @@ -76,18 +81,20 @@ genDelayWithPrecision precision = -- instance Arbitrary Delay where arbitrary = Delay <$> genDelayWithPrecision 10 - shrink (Delay delay) | delay >= 0.1 = [ Delay (delay - 0.1) ] - | otherwise = [] + shrink delay | delay > 0.1 = + takeWhile (>= 0.1) . map fromRational . shrink . toRational $ delay + shrink _delay = [] newtype SmallDelay = SmallDelay { getSmallDelay :: DiffTime } deriving Show - deriving newtype (Eq, Ord, Num) + deriving newtype (Eq, Ord, Num, Fractional, Real) instance Arbitrary SmallDelay where arbitrary = resize 5 $ SmallDelay . getDelay <$> suchThat arbitrary (\(Delay d ) -> d < 5) - shrink (SmallDelay delay) | delay >= 0.1 = [ SmallDelay (delay - 0.1) ] - | otherwise = [] + shrink delay | delay > 0.1 = + takeWhile (>= 0.1) . map fromRational . shrink . toRational $ delay + shrink _delay = [] -- | Pick a subset of a set, using a 50:50 chance for each set element. -- @@ -167,13 +174,19 @@ data WithName name event = WithName { wnName :: name, wnEvent :: event } - deriving (Show, Functor) + deriving (Functor) + +instance (Show name, Show event) => Show (WithName name event) where + show (WithName name ev) = "#" <> show name <> " %" <> show ev data WithTime event = WithTime { wtTime :: Time, wtEvent :: event } - deriving (Show, Functor) + deriving (Functor) + +instance Show event => Show (WithTime event) where + show (WithTime t ev) = "@" <> show t <> " " <> show ev tracerWithName :: name -> Tracer m (WithName name a) -> Tracer m a tracerWithName name = contramap (WithName name) @@ -227,6 +240,17 @@ debugTracer = Tracer traceShowM sayTracer :: ( Show a, MonadSay m) => Tracer m a sayTracer = Tracer (say . show) +-- | Redefine this tracer to get valuable tracing information from various +-- components: +-- +-- * connection-manager +-- * inbound governor +-- * server +-- +debugTracerG :: (Show a, Typeable a) => Tracer (IOSim s) a +debugTracerG = Tracer (\msg -> getCurrentTime >>= say . show . (,msg)) + <> Tracer traceM + -- <> Tracer Debug.traceShowM -- -- Nightly tests diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs index f69a4fc09ae..33be92b7ca0 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs @@ -217,7 +217,7 @@ demo chain0 updates = do InitiatorProtocolOnly initiator -> [(Mx.InitiatorDirectionOnly, void . runMiniProtocolCb initiator initCtx)] ] - withAsync (Mx.run nullTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) clientMux clientBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop clientMux wait aid @@ -242,7 +242,7 @@ demo chain0 updates = do ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] ] - withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop serverMux wait aid diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index f327011fe3c..029c637bd3a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} @@ -48,13 +49,12 @@ import System.Random (StdGen, newStdGen, split) import Network.DNS (Resolver) import Network.Mux qualified as Mx import Network.Mux.Bearer (withReadBufferIO) +import Network.Mux.Types import Network.Socket (Socket) import Network.Socket qualified as Socket 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) @@ -64,6 +64,8 @@ import Ouroboros.Network.Diffusion.Types import Ouroboros.Network.Diffusion.Utils import Ouroboros.Network.ExitPolicy import Ouroboros.Network.InboundGovernor qualified as IG +import Ouroboros.Network.InboundGovernor.InformationChannel (InformationChannel, + newInformationChannel) import Ouroboros.Network.IOManager import Ouroboros.Network.Mux hiding (MiniProtocol (..)) import Ouroboros.Network.MuxMode @@ -316,12 +318,11 @@ runM Interfaces let localConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0 - localConnectionHandler :: NodeToClientConnectionHandler - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionHandler = + mkLocalConnectionHandler :: MkNodeToClientConnectionHandler + ntcFd ntcAddr ntcVersion ntcVersionData m + mkLocalConnectionHandler responderMuxChannelTracer = makeConnectionHandler dtLocalMuxTracer - SingResponderMode dcLocalMuxForkPolicy daNtcHandshakeArguments ( ( \ (OuroborosApplication apps) @@ -331,12 +332,20 @@ runM Interfaces (WithEstablished []) ) <$> daLocalResponderApplication ) (mainThreadId, rethrowPolicy <> daLocalRethrowPolicy) - - localConnectionManagerArguments - :: NodeToClientConnectionManagerArguments - ntcFd ntcAddr ntcVersion ntcVersionData m - localConnectionManagerArguments = - CM.Arguments { + (MuxResponderConnectionHandler responderMuxChannelTracer) + + localWithConnectionManager + :: InformationChannel + (IG.Event 'ResponderMode handle initiatorCtx ntcAddr versionData m c b) m + -> ConnectionHandler 'ResponderMode (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd ntcAddr handle (HandleError muxMode versionNumber) version + versionData m + -> ( ConnectionManager 'ResponderMode ntcFd ntcAddr handle + (HandleError muxMode versionNumber) m + -> m x) + -> m x + localWithConnectionManager responderInfoChannel connectionHandler k = + CM.with CM.Arguments { CM.tracer = dtLocalConnectionManagerTracer, CM.trTracer = nullTracer, -- TODO: issue #3320 CM.muxTracer = dtLocalMuxTracer, @@ -354,36 +363,33 @@ runM Interfaces CM.stdGen = cmLocalStdGen, CM.connectionsLimits = localConnectionLimits, CM.updateVersionData = \a _ -> a, - CM.connStateIdSupply = diConnStateIdSupply + CM.connStateIdSupply = diConnStateIdSupply, + CM.classifyHandleError } - - 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) + (InResponderMode responderInfoChannel) + connectionHandler + k + + traceWith tracer . RunLocalServer =<< Snocket.getLocalAddr diNtcSnocket localSocket + Server.with + Server.Arguments { + Server.sockets = localSocket :| [], + Server.snocket = diNtcSnocket, + Server.tracer = dtLocalServerTracer, + Server.connectionLimits = localConnectionLimits, + inboundGovernorArgs = + IG.Arguments { + tracer = dtLocalInboundGovernorTracer, + transitionTracer = nullTracer, + debugTracer = nullTracer, + connectionDataFlow = ntcDataFlow, + idleTimeout = Nothing, + withConnectionManager = localWithConnectionManager localInbInfoChannel, + mkConnectionHandler = mkLocalConnectionHandler, + infoChannel = localInbInfoChannel + } + } + (\inboundGovernorThread _ _ -> Async.wait inboundGovernorThread) -- | mkRemoteThread - create remote connection manager @@ -452,12 +458,12 @@ runM Interfaces -- let connectionManagerArguments' - :: forall handle handleError. + :: forall muxMode handle b. PrunePolicy ntnAddr -> StdGen -> CM.Arguments (ConnectionHandlerTrace ntnVersion ntnVersionData) - ntnFd ntnAddr handle handleError ntnVersion ntnVersionData m + ntnFd ntnAddr handle (HandleError muxMode ntnVersion) ntnVersion ntnVersionData m a b connectionManagerArguments' prunePolicy stdGen = CM.Arguments { CM.tracer = dtConnectionManagerTracer, @@ -479,21 +485,22 @@ runM Interfaces CM.timeWaitTimeout = dcTimeWaitTimeout, CM.outboundIdleTimeout = dcProtocolIdleTimeout, CM.updateVersionData = daUpdateVersionData, - CM.connStateIdSupply = diConnStateIdSupply + CM.connStateIdSupply = diConnStateIdSupply, + CM.classifyHandleError } let makeConnectionHandler' - :: forall muxMode socket initiatorCtx responderCtx b c. - SingMuxMode muxMode - -> Versions ntnVersion ntnVersionData + :: forall muxMode initiatorCtx responderCtx b c. + Versions ntnVersion ntnVersionData (OuroborosBundle muxMode initiatorCtx responderCtx ByteString m b c) - -> MuxConnectionHandler - muxMode socket initiatorCtx responderCtx ntnAddr + -> MkMuxConnectionHandler + muxMode ntnFd initiatorCtx responderCtx ntnAddr ntnVersion ntnVersionData ByteString m b c - makeConnectionHandler' muxMode versions = + -> MuxConnectionHandler muxMode ntnFd initiatorCtx responderCtx ntnAddr + ntnVersion ntnVersionData ByteString m b c + makeConnectionHandler' versions = makeConnectionHandler dtMuxTracer - muxMode dcMuxForkPolicy daNtnHandshakeArguments versions @@ -502,28 +509,26 @@ runM Interfaces -- | Capture the two variations (InitiatorMode,InitiatorResponderMode) of -- withConnectionManager: - withConnectionManagerInitiatorOnlyMode = + withConnectionManagerInitiatorOnlyMode k = 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 + (makeConnectionHandler' daApplicationInitiatorMode + MuxInitiatorConnectionHandler) + k withConnectionManagerInitiatorAndResponderMode - inbndInfoChannel = + responderInfoChannel connectionHandler k = CM.with - (connectionManagerArguments' Diffusion.Policies.prunePolicy cmStdGen2) - (makeConnectionHandler' - SingInitiatorResponderMode - daApplicationInitiatorResponderMode) - classifyHandleError - (InResponderMode inbndInfoChannel) + (connectionManagerArguments' Diffusion.Policies.prunePolicy + cmStdGen2) + (InResponderMode responderInfoChannel) + connectionHandler + k -- -- peer state actions @@ -704,21 +709,29 @@ runM Interfaces 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 = dcAcceptedConnectionsLimit, - Server.connectionManager = connectionManager, - Server.connectionDataFlow = daNtnDataFlow, - Server.inboundIdleTimeout = Just dcProtocolIdleTimeout, - Server.inboundInfoChannel = inboundInfoChannel - } + withServer sockets inboundInfoChannel = + Server.with + Server.Arguments { + Server.sockets = sockets, + Server.snocket = diNtnSnocket, + Server.tracer = dtServerTracer, + Server.connectionLimits + = dcAcceptedConnectionsLimit, + inboundGovernorArgs = + IG.Arguments { + tracer = dtInboundGovernorTracer, + transitionTracer = dtInboundGovernorTransitionTracer, + debugTracer = nullTracer, + connectionDataFlow = daNtnDataFlow, + idleTimeout = Just dcProtocolIdleTimeout, + withConnectionManager = + withConnectionManagerInitiatorAndResponderMode inboundInfoChannel, + mkConnectionHandler = + makeConnectionHandler' daApplicationInitiatorResponderMode + . MuxInitiatorResponderConnectionHandler daNtnDataFlow, + infoChannel = inboundInfoChannel + } + } -- -- Part (b): capturing the major control-flow of runM: @@ -727,7 +740,7 @@ runM Interfaces -- InitiatorOnly mode, run peer selection only: InitiatorOnlyDiffusionMode -> - withConnectionManagerInitiatorOnlyMode $ \connectionManager-> do + withConnectionManagerInitiatorOnlyMode $ \connectionManager -> do debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty daInstallSigUSR1Handler connectionManager debugStateVar withPeerStateActions' connectionManager $ \peerStateActions-> @@ -748,45 +761,43 @@ runM Interfaces -- 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 $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty - daInstallSigUSR1Handler connectionManager debugStateVar - 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 - ] + inboundInfoChannel <- newInformationChannel + -- + -- node-to-node sockets + -- + withSockets' \sockets addresses -> do + -- + -- node-to-node server + -- + -- begin, unique to InitiatorAndResponder mode: + traceWith tracer (RunServer addresses) + -- end, unique to ... + withServer sockets inboundInfoChannel + \inboundGovernorThread readInboundState connectionManager -> do + debugStateVar <- newTVarIO $ Governor.emptyPeerSelectionState fuzzRng daEmptyExtraState mempty + daInstallSigUSR1Handler connectionManager debugStateVar + withPeerStateActions' connectionManager $ + \peerStateActions -> + withPeerSelectionActions' + (mkInboundPeersMap <$> readInboundState) + peerStateActions $ + \(ledgerPeersThread, localRootPeersProvider) peerSelectionActions -> + Async.withAsync + (do + labelThisThread "Peer selection governor" + peerSelectionGovernor' dtDebugPeerSelectionInitiatorResponderTracer debugStateVar peerSelectionActions) $ + \governorThread -> do + 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: -- diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs index c52abbe49fc..9cd552c3c8d 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Types.hs @@ -21,8 +21,7 @@ module Ouroboros.Network.Diffusion.Types -- * NodeToClient type aliases , NodeToClientHandle , NodeToClientHandleError - , NodeToClientConnectionHandler - , NodeToClientConnectionManagerArguments + , MkNodeToClientConnectionHandler -- * NodeToNode type aliases , NodeToNodeHandle , NodeToNodeConnectionManager @@ -41,12 +40,14 @@ import Control.Tracer (Tracer, nullTracer) import Data.ByteString.Lazy (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) +import Data.Maybe.Strict import Data.Set (Set) import Data.Typeable (Typeable) import Data.Void (Void) import System.Random (StdGen) import Network.Mux qualified as Mx +import Network.Mux.Trace qualified as Mux import Network.Mux.Types (ReadBuffer) import Network.Socket qualified as Socket @@ -565,31 +566,20 @@ type NodeToClientHandle ntcAddr versionData m = type NodeToClientHandleError ntcVersion = HandleError Mx.ResponderMode ntcVersion -type NodeToClientConnectionHandler +type MkNodeToClientConnectionHandler 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 - + ( StrictTVar m (StrictMaybe IG.ResponderCounters) + -> Tracer m (Mux.WithBearer (ConnectionId ntcAddr) Mux.Trace)) + -> ConnectionHandler + Mx.ResponderMode + (ConnectionHandlerTrace ntcVersion ntcVersionData) + ntcFd + ntcAddr + (NodeToClientHandle ntcAddr ntcVersionData m) + (NodeToClientHandleError ntcVersion) + ntcVersion + ntcVersionData + m -- -- Node-To-Node type aliases diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index e6098797a86..d6ae4a42fe6 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -28,6 +28,7 @@ import Data.Bifunctor (first) import Data.Dynamic (fromDynamic) import Data.Foldable (fold) import Data.IP qualified as IP +import Data.List (intercalate) import Data.List qualified as List import Data.List.Trace qualified as Trace import Data.Map (Map) @@ -302,7 +303,9 @@ testWithIOSim f traceNumber bi ds = iosimTracer trace = runSimTrace sim in labelDiffusionScript ds - $ counterexample (Trace.ppTrace show (ppSimEvent 0 0 0) $ Trace.take traceNumber trace) + $ counterexample (intercalate "\n" $ + selectTraceEventsSay' $ Trace.take traceNumber trace) + --counterexample (Trace.ppTrace show (ppSimEvent 0 0 0) $ Trace.take traceNumber trace) $ f trace traceNumber diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs index 48a488d0674..9eec2ca537d 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano/Simulation.hs @@ -70,6 +70,7 @@ import Network.DNS qualified as DNS import System.Random (StdGen, mkStdGen) import System.Random qualified as Random +import Network.Mux qualified as Mux import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Type qualified as PingPong @@ -99,6 +100,7 @@ import Ouroboros.Network.Block (BlockNo) import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..), TraceFetchClientState, TraceLabelPeer (..)) import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) +import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Core qualified as CM import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (AbstractTransitionTrace) @@ -253,6 +255,7 @@ data Command = JoinNetwork DiffTime , WarmValency , Map RelayAccessPoint (LocalRootConfig PeerTrustable) )] + | Skip DiffTime deriving Eq instance Show Command where @@ -264,6 +267,9 @@ instance Show Command where . showsPrec d delay . showString " " . showsPrec d localRoots + showsPrec d (Skip delay) = showString "Skip" + . showsPrec d delay + . showString " " genCommands :: [( HotValency , WarmValency @@ -293,17 +299,20 @@ genCommands localRoots = sized $ \size -> do fixupCommands :: [Command] -> [Command] fixupCommands [] = [] -fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t +fixupCommands (jn@(JoinNetwork _):t) = jn : go jn 0 t where - go :: Command -> [Command] -> [Command] - go _ [] = [] - go prev (cmd:cmds) = + go :: Command -> DiffTime -> [Command] -> [Command] + go _ _ [] = [] + go prev accDelay (cmd:cmds) = case (prev, cmd) of - (JoinNetwork _ , JoinNetwork _ ) -> go prev cmds - (Kill _ , Kill _ ) -> go prev cmds - (Kill _ , Reconfigure _ _ ) -> go prev cmds - (Reconfigure _ _ , JoinNetwork _ ) -> go prev cmds - _ -> cmd : go cmd cmds + (JoinNetwork _ , JoinNetwork _ ) -> go prev accDelay cmds + (Kill _ , Kill _ ) -> go prev accDelay cmds + (Kill _ , Reconfigure _ _ ) -> go prev accDelay cmds + (Reconfigure _ _ , JoinNetwork _ ) -> go prev accDelay cmds + (_ , Skip d ) -> go prev (d + accDelay) cmds + (_ , JoinNetwork d ) -> JoinNetwork (d + accDelay) : go cmd 0 cmds + (_ , Kill d ) -> Kill (d + accDelay) : go cmd 0 cmds + (_ , Reconfigure d c ) -> Reconfigure (d + accDelay) c : go cmd 0 cmds fixupCommands (_:t) = fixupCommands t -- | Simulation arguments. @@ -374,9 +383,12 @@ genNodeArgs relays minConnected localRootPeers self = flip suchThat hasUpstream -- Generating an InitiatorResponderMode node is 3 times more likely since we -- want our tests to cover more this case. - diffusionMode <- frequency [ (1, pure InitiatorOnlyDiffusionMode) - , (3, pure InitiatorAndResponderDiffusionMode) - ] + -- diffusionMode <- frequency [ (1, pure InitiatorOnlyDiffusionMode) + -- , (3, pure InitiatorAndResponderDiffusionMode) + -- ] + -- TODO: 'cm & ig enforce timeouts' fails in 'InitiatorOnlyDiffusionMode' + -- so we pin it to this + let diffusionMode = InitiatorAndResponderDiffusionMode -- These values approximately correspond to false positive -- thresholds for streaks of empty slots with 99% probability, @@ -773,44 +785,48 @@ instance Arbitrary DiffusionScript where <$> frequency [ (1, arbitrary >>= genNonHotDiffusionScript) , (1, arbitrary >>= genHotDiffusionScript)] -- TODO: shrink dns map - -- TODO: we should write more careful shrinking than recursively shrinking - -- `DiffusionScript`! - shrink (DiffusionScript sargs dnsScript cmds0) = shrinkCmds cmds0 ++ shrinkDns + shrink (DiffusionScript sargs dnsScript0 players0) = + [DiffusionScript sargs dnsScript0 players + | players <- shrinkPlayers players0 + ] <> + [DiffusionScript sargs dnsScript players0 + | dnsScript <- + mapMaybe + -- make sure `fixupDomainMapScript` didn't return something that's + -- equal to the original `script` + ((\dnsScript' -> if dnsScript0 == dnsScript' then Nothing else Just dnsScript') + . fixupDomainMapScript (getLast dnsScript0)) + $ shrinkScriptWith (liftShrink2 shrinkMap_ shrink) dnsScript0 + ] where - shrinkDns = - [DiffusionScript sargs script cmds0 - | script <- - mapMaybe - -- make sure `fixupDomainMapScript` didn't return something that's - -- equal to the original `script` - ((\dnsScript' -> if dnsScript == dnsScript' then Nothing else Just dnsScript') - . fixupDomainMapScript (getLast dnsScript)) - $ shrinkScriptWith (shrinkTuple shrinkMap_ shrink) dnsScript - ] - getLast (Script ne) = fst $ NonEmpty.last ne shrinkMap_ :: Ord a => Map a b -> [Map a b] shrinkMap_ = map Map.fromList . shrinkList (const []) . Map.toList - shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] - shrinkTuple f g (a, b) = [(a', b) | a' <- f a] - ++ [(a, b') | b' <- g b] + -- the easiest failure to analyze is the one with the least number of nodes participating. + -- Currently we use up to three nodes, but in case we increase the number in the future + -- this will be even more useful. + shrinkPlayers = + filter ((> 1) . length) . shrinkList shrinkPlayer - shrinkCmds [] = [] - shrinkCmds ((nargs, cmds):rest) = - let shrunkCmdss = fixupCommands <$> shrinkList shrinkCommand cmds - rest' = shrinkCmds rest - in [DiffusionScript sargs dnsScript ((nargs, shrunkCmds):rest) - | shrunkCmds <- shrunkCmdss] ++ rest' + shrinkPlayer (nargs, cmds) = + map (nargs,) . filter (/= cmds) $ fixupCommands <$> shrinkList shrinkCommand cmds where shrinkDelay = map fromRational . shrink . toRational + -- A failing network with the least nodes active at a particular time is the simplest to analyze, + -- if for no other reason other than for having the least amount of traces for us to read. + -- A dead node is its simplest configuration as that can't contribute to its failure, + -- So we shrink to that first to see at least if a failure occurs somewhere else still. + -- Otherwise we know that this node has to be running for sure while the exchange is happening. shrinkCommand :: Command -> [Command] shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d - shrinkCommand (Kill d) = Kill <$> shrinkDelay d - shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d - <*> pure lrp + shrinkCommand (Kill d) = Kill <$> shrinkDelay d + shrinkCommand (Reconfigure d lrp) = Skip d + : (Reconfigure <$> shrinkDelay d + <*> pure lrp) + shrinkCommand (Skip _d) = [] -- | Multinode Hot Diffusion Simulator Script @@ -882,6 +898,7 @@ data DiffusionSimulationTrace | TrRunning | TrErrored SomeException | TrTerminated + | TrSay String deriving Show -- Warning: be careful with writing properties that rely @@ -912,6 +929,7 @@ data DiffusionTestTrace = | DiffusionChurnModeTrace TracerChurnMode | DiffusionDebugTrace String | DiffusionDNSTrace DNSTrace + | DiffusionMuxTrace (Mux.WithBearer (ConnectionId NtNAddr) Mux.Trace) deriving (Show) @@ -922,7 +940,7 @@ iosimTracer :: forall s a. , Typeable a ) => Tracer (IOSim s) (WithTime (WithName NtNAddr a)) -iosimTracer = Tracer traceM <> sayTracer +iosimTracer = Tracer traceM -- <> sayTracer -- | Run an arbitrary topology diffusionSimulation @@ -961,8 +979,10 @@ diffusionSimulation $ \ntcSnocket _ -> do dnsMapVar <- fromLazyTVar <$> playTimedScript nullTracer dnsMapScript withAsyncAll - (map ((\(args, commands) -> runCommand Nothing ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply commands)) - nodeArgs) + (zipWith + (\(args, commands) i -> runCommand ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply i Nothing commands) + nodeArgs + [1..]) $ \nodes -> do (_, x) <- waitAny nodes return x @@ -973,14 +993,7 @@ diffusionSimulation -- | Runs a single node according to a list of commands. runCommand - :: Maybe ( Async m Void - , StrictTVar m [( HotValency - , WarmValency - , Map RelayAccessPoint (LocalRootConfig PeerTrustable) - )]) - -- ^ If the node is running and corresponding local root configuration - -- TVar. - -> Snocket m (FD m NtNAddr) NtNAddr + :: Snocket m (FD m NtNAddr) NtNAddr -- ^ Node to node Snocket -> Snocket m (FD m NtCAddr) NtCAddr -- ^ Node to client Snocket @@ -989,45 +1002,60 @@ diffusionSimulation -> SimArgs -- ^ Simulation arguments needed in order to run a simulation -> NodeArgs -- ^ Simulation arguments needed in order to run a single node -> CM.ConnStateIdSupply m + -> Int + -> Maybe ( Async m Void + , StrictTVar m [( HotValency + , WarmValency + , Map RelayAccessPoint (LocalRootConfig PeerTrustable) + )]) + -- ^ If the node is running and corresponding local root configuration + -- TVar. -> [Command] -- ^ List of commands/actions to perform for a single node -> m Void - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply [] = do - threadDelay 3600 - traceWith (diffSimTracer (naAddr nArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply [] - runCommand (Just (_, _)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply [] = do - -- We shouldn't block this thread waiting - -- on the async since this will lead to a deadlock - -- as thread returns 'Void'. - threadDelay 3600 - traceWith (diffSimTracer (naAddr nArgs)) TrRunning - runCommand Nothing ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply [] - runCommand Nothing ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply - (JoinNetwork delay :cs) = do - threadDelay delay - traceWith (diffSimTracer (naAddr nArgs)) TrJoiningNetwork - lrpVar <- newTVarIO $ naLocalRootPeers nArgs - withAsync (runNode sArgs nArgs ntnSnocket ntcSnocket connStateIdSupply lrpVar dnsMapVar) $ \nodeAsync -> - runCommand (Just (nodeAsync, lrpVar)) ntnSnocket ntcSnocket dnsMapVar sArgs nArgs connStateIdSupply cs - runCommand _ _ _ _ _ _ _ (JoinNetwork _:_) = - error "runCommand: Impossible happened" - runCommand (Just (async_, _)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply - (Kill delay:cs) = do - threadDelay delay - traceWith (diffSimTracer (naAddr nArgs)) TrKillingNode - cancel async_ - runCommand Nothing ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply cs - runCommand _ _ _ _ _ _ _ (Kill _:_) = do - error "runCommand: Impossible happened" - runCommand Nothing _ _ _ _ _ _ (Reconfigure _ _:_) = - error "runCommand: Impossible happened" - runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply - (Reconfigure delay newLrp:cs) = do - threadDelay delay - traceWith (diffSimTracer (naAddr nArgs)) TrReconfiguringNode - _ <- atomically $ writeTVar lrpVar newLrp - runCommand (Just (async_, lrpVar)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply - cs + runCommand ntnSocket ntcSocket dnsMapVar sArgs nArgs@NodeArgs { naAddr } + connStateIdSupply i hostAndLRP cmds = do + traceWith (diffSimTracer naAddr) . TrSay $ "node-" <> show i + runCommand' hostAndLRP cmds + where + runCommand' Nothing [] = do + threadDelay 3600 + traceWith (diffSimTracer naAddr) TrRunning + runCommand' Nothing [] + runCommand' (Just (_, _)) [] = do + -- We shouldn't block this thread waiting + -- on the async since this will lead to a deadlock + -- as thread returns 'Void'. + threadDelay 3600 + traceWith (diffSimTracer naAddr) TrRunning + runCommand' Nothing [] + runCommand' Nothing + (JoinNetwork delay :cs) = do + threadDelay delay + traceWith (diffSimTracer naAddr) TrJoiningNetwork + lrpVar <- newTVarIO $ naLocalRootPeers nArgs + withAsync (runNode sArgs nArgs ntnSocket ntcSocket connStateIdSupply lrpVar dnsMapVar i) $ \nodeAsync -> + runCommand' (Just (nodeAsync, lrpVar)) cs + runCommand' _ (JoinNetwork _:_) = + error "runCommand: Impossible happened" + runCommand' (Just (async_, _)) + (Kill delay:cs) = do + threadDelay delay + traceWith (diffSimTracer naAddr) TrKillingNode + cancel async_ + runCommand' Nothing cs + runCommand' _ (Kill _:_) = do + error "runCommand: Impossible happened" + runCommand' Nothing (Reconfigure _ _:_) = + error "runCommand: Impossible happened" + runCommand' (Just (async_, lrpVar)) + (Reconfigure delay newLrp:cs) = do + threadDelay delay + traceWith (diffSimTracer naAddr) TrReconfiguringNode + _ <- atomically $ writeTVar lrpVar newLrp + runCommand' (Just (async_, lrpVar)) + cs + runCommand' _ (Skip _ : _) = + error "runCommand: Impossible happened" runNode :: SimArgs -> NodeArgs @@ -1039,6 +1067,7 @@ diffusionSimulation , Map RelayAccessPoint (LocalRootConfig PeerTrustable) )] -> StrictTVar m MockDNSMap + -> Int -> m Void runNode SimArgs { saSlot = bgaSlotDuration @@ -1058,12 +1087,13 @@ diffusionSimulation , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing + , naDiffusionMode = diffusionMode } ntnSnocket ntcSnocket connStateIdSupply lrpVar - dMapVar = do + dMapVar i = do chainSyncExitVar <- newTVarIO chainSyncExitOnBlockNo ledgerPeersVar <- initScript' ledgerPeers onlyOutboundConnectionsStateVar <- newTVarIO UntrustedState @@ -1074,7 +1104,6 @@ diffusionSimulation (bgaRng, rng) = Random.split $ mkStdGen seed acceptedConnectionsLimit = AcceptedConnectionsLimit maxBound maxBound 0 - diffusionMode = InitiatorAndResponderDiffusionMode readLocalRootPeers = readTVar lrpVar readPublicRootPeers = return publicRoots readUseLedgerPeers = return (UseLedgerPeers (After 0)) @@ -1211,7 +1240,7 @@ diffusionSimulation , Node.aExtraChurnArgs = cardanoChurnArgs } - tracers = mkTracers addr + tracers = mkTracers addr i requestPublicRootPeers' = requestPublicRootPeers (Diffusion.dtTracePublicRootPeersTracer tracers) @@ -1282,61 +1311,72 @@ diffusionSimulation diffSimTracer ntnAddr = contramap DiffusionSimulationTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer <> sayTracer mkTracers :: NtNAddr + -> Int -> Diffusion.Tracers NtNAddr NtNVersion NtNVersionData NtCAddr NtCVersion NtCVersionData SomeException Cardano.ExtraState Cardano.ExtraState PeerTrustable (Cardano.ExtraPeers NtNAddr) (Cardano.ExtraPeerSelectionSetsWithSizes NtNAddr) m - mkTracers ntnAddr = + mkTracers ntnAddr i = + let sayTracer' = Tracer \msg -> say $ "(node-" <> show i <> ")" <> show msg + -- toggle and uncomment interesting sayTracer' below + nodeTracer' = if True then nodeTracer <> sayTracer' else nodeTracer in + Diffusion.nullTracers { + -- Diffusion.dtMuxTracer = contramap + -- DiffusionMuxTrace + -- . tracerWithName ntnAddr + -- . tracerWithTime + -- $ nodeTracer' -- <> sayTracer', Diffusion.dtTraceLocalRootPeersTracer = contramap - DiffusionLocalRootPeerTrace + DiffusionLocalRootPeerTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTracePublicRootPeersTracer = contramap - DiffusionPublicRootPeerTrace + DiffusionPublicRootPeerTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTraceLedgerPeersTracer = contramap - DiffusionLedgerPeersTrace + DiffusionLedgerPeersTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTracePeerSelectionTracer = contramap - DiffusionPeerSelectionTrace + DiffusionPeerSelectionTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtDebugPeerSelectionInitiatorTracer = contramap - DiffusionDebugPeerSelectionTrace + DiffusionDebugPeerSelectionTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtDebugPeerSelectionInitiatorResponderTracer - = contramap DiffusionDebugPeerSelectionTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + = contramap + DiffusionDebugPeerSelectionTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' , Diffusion.dtTracePeerSelectionCounters = nullTracer , Diffusion.dtTraceChurnCounters = nullTracer , Diffusion.dtPeerSelectionActionsTracer = contramap - DiffusionPeerSelectionActionsTrace + DiffusionPeerSelectionActionsTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtConnectionManagerTracer = contramap - DiffusionConnectionManagerTrace + DiffusionConnectionManagerTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' , Diffusion.dtConnectionManagerTransitionTracer = contramap DiffusionConnectionManagerTransitionTrace @@ -1345,30 +1385,30 @@ diffusionSimulation -- note: we have two ways getting transition trace: -- * through `traceTVar` installed in `newMutableConnState` -- * the `dtConnectionManagerTransitionTracer` - $ nodeTracer - , Diffusion.dtServerTracer = contramap - DiffusionServerTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer - , Diffusion.dtInboundGovernorTracer = contramap - DiffusionInboundGovernorTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' + , Diffusion.dtServerTracer = contramap + DiffusionServerTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' + , Diffusion.dtInboundGovernorTracer = contramap + DiffusionInboundGovernorTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' , Diffusion.dtInboundGovernorTransitionTracer = contramap DiffusionInboundGovernorTransitionTrace . tracerWithName ntnAddr . tracerWithTime - $ nodeTracer - , Diffusion.dtLocalConnectionManagerTracer = nullTracer - , Diffusion.dtLocalServerTracer = nullTracer - , Diffusion.dtLocalInboundGovernorTracer = nullTracer - , Diffusion.dtDnsTracer = contramap DiffusionDNSTrace - . tracerWithName ntnAddr - . tracerWithTime - $ nodeTracer + $ nodeTracer' -- <> sayTracer' + , Diffusion.dtLocalConnectionManagerTracer = nullTracer + , Diffusion.dtLocalServerTracer = nullTracer + , Diffusion.dtLocalInboundGovernorTracer = nullTracer + , Diffusion.dtDnsTracer = contramap DiffusionDNSTrace + . tracerWithName ntnAddr + . tracerWithTime + $ nodeTracer' -- <> sayTracer' } diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs index 002b11bf003..3a60899fc1b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Mux.hs @@ -186,7 +186,7 @@ demo chain0 updates delay = do InitiatorProtocolOnly initiator -> [(Mx.InitiatorDirectionOnly, void . runMiniProtocolCb initiator initCtx)] ] - withAsync (Mx.run nullTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) clientMux clientBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop clientMux wait aid @@ -211,7 +211,7 @@ demo chain0 updates delay = do ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] ] - withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run (Mx.Tracers nullTracer nullTracer) serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop serverMux wait aid