framework: added traces to the simple server

Author: coot

cardano-diffusion/demo/chain-sync.hs

@@ -276,6 +276,8 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do
       Just a  -> return (Random.mkStdGen a)
     Server.Simple.with
       (localSnocket iocp)
+      nullTracer
+      Mx.nullTracers
       makeLocalBearer
       mempty
       (localAddressFromPath sockAddr)
@@ -552,6 +554,8 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do
       Just a  -> return (Random.mkStdGen a)
     Server.Simple.with
       (localSnocket iocp)
+      nullTracer
+      Mx.nullTracers
       makeLocalBearer
       mempty
       (localAddressFromPath sockAddr)

ouroboros-network/changelog.d/20251016_085523_coot_simple_server_fix.md

@@ -0,0 +1,8 @@
+### Breaking
+
+- `Ouroboros.Network.Server.Simple.with` now requires tracers as argument,
+  these should not be nullTracers in production code, although
+  `Network.Mux.Trace.ChannelTrace` and `Network.Mux.Trace.BearerTrace` should
+  be off by default as they can be extensive, the `Network.Mux.Trace.Trace` can
+  be on by default, while `Ouroboros.Network.Server.Simple.ServerTrace` must be
+  on as it traces important exception.

ouroboros-network/demo/ping-pong.hs

@@ -160,6 +160,8 @@ serverPingPong =
     withIOManager $ \iomgr -> do
     Server.with
       (Snocket.localSnocket iomgr)
+      nullTracer
+      Mx.nullTracers
       makeLocalBearer
       mempty
       defaultLocalSocketAddr
@@ -255,6 +257,8 @@ serverPingPong2 =
     withIOManager $ \iomgr -> do
     Server.with
       (Snocket.localSnocket iomgr)
+      nullTracer
+      Mx.nullTracers
       makeLocalBearer
       mempty
       defaultLocalSocketAddr

ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs

@@ -240,6 +240,8 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs =
     res <-
       Server.Simple.with
         snocket
+        nullTracer
+        Mx.nullTracers
         Mx.makeSocketBearer
         ((. Just) <$> configureSock)
         responderAddr

ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs

@@ -9,7 +9,10 @@
 -- of inbound connections) and thus should only be used in a safe environment.
 --
 -- The module should be imported qualified.
-module Ouroboros.Network.Server.Simple where
+module Ouroboros.Network.Server.Simple
+  ( with
+  , ServerTracer (..)
+  ) where
 
 import Control.Applicative (Alternative)
 import Control.Concurrent.JobPool qualified as JobPool
@@ -18,6 +21,7 @@ import Control.Monad.Class.MonadFork (MonadFork)
 import Control.Monad.Class.MonadSTM
 import Control.Monad.Class.MonadThrow
 import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer)
+import Control.Tracer (Tracer, traceWith)
 import Data.ByteString.Lazy qualified as BL
 import Data.Functor (void)
 import Data.Typeable (Typeable)
@@ -33,13 +37,11 @@ import Ouroboros.Network.Snocket (Snocket)
 import Ouroboros.Network.Snocket qualified as Snocket
 import Ouroboros.Network.Socket
 
+data ServerTracer addr
+  = AcceptException SomeException
+  | ConnectionHandlerException (ConnectionId addr) SomeException
+  deriving Show
 
--- TODO: add tracers:
---
--- * accept errors,
--- * errors thrown by a connection handler thread,
--- * mux tracers
---
 with :: forall fd addr vNumber vData m a b.
         ( Alternative (STM m),
           MonadAsync m,
@@ -54,14 +56,16 @@ with :: forall fd addr vNumber vData m a b.
           Show vNumber
         )
      => Snocket m fd addr
+     -> Tracer m (ServerTracer addr)
+     -> Mx.TracersWithBearer (ConnectionId addr) m
      -> Mx.MakeBearer m fd
      -> (fd -> addr -> m ())
      -> addr
      -> HandshakeArguments (ConnectionId addr) vNumber vData m
      -> Versions vNumber vData (SomeResponderApplication addr BL.ByteString m b)
      -> (addr -> Async m Void -> m a)
      -> m a
-with sn makeBearer configureSock addr handshakeArgs versions k =
+with sn tracer muxTracers makeBearer configureSock addr handshakeArgs versions k =
    JobPool.withJobPool $ \jobPool ->
    bracket
      (do sd <- Snocket.open sn (Snocket.addrFamily sn addr)
@@ -71,49 +75,59 @@ with sn makeBearer configureSock addr handshakeArgs versions k =
          addr' <- Snocket.getLocalAddr sn sd
          pure (sd, addr'))
      (Snocket.close sn . fst)
-     (\(sock, addr') ->
+     (\(sock, localAddress) ->
        -- accept loop
-       withAsync (Snocket.accept sn sock >>= acceptLoop jobPool) (k addr')
+       withAsync (Snocket.accept sn sock >>= acceptLoop jobPool localAddress)
+                 (k localAddress)
      )
   where
     acceptLoop :: JobPool.JobPool () m ()
+               -> addr
                -> Snocket.Accept m fd addr
                -> m Void
-    acceptLoop jobPool Snocket.Accept { Snocket.runAccept } = do
+    acceptLoop
+        jobPool
+        localAddress
+        Snocket.Accept { Snocket.runAccept }
+        = do
         (accepted, acceptNext) <- runAccept
         acceptOne accepted
-        acceptLoop jobPool acceptNext
+        acceptLoop jobPool
+                   localAddress
+                   acceptNext
       where
         -- handle accept failures and fork a connection thread which performs
         -- a handshake and runs mux
         acceptOne :: Snocket.Accepted fd addr -> m ()
         acceptOne (Snocket.AcceptFailure e)
           | Just ioErr <- fromException e
           , isECONNABORTED ioErr
-          = return ()
+          = traceWith tracer (AcceptException e)
         acceptOne (Snocket.AcceptFailure e)
-          = throwIO e
+          = do traceWith tracer (AcceptException e)
+               throwIO e
 
-        acceptOne (Snocket.Accepted sock' remoteAddr) = do
-            let connThread = do
+        acceptOne (Snocket.Accepted sock' remoteAddress) = do
+            let connId = ConnectionId { localAddress, remoteAddress }
+                connThread = do
                   -- connection responder thread
-                  let connId = ConnectionId addr remoteAddr
                   bearer <- Mx.getBearer makeBearer (-1) sock' Nothing
-                  configureSock sock' addr
+                  configureSock sock' localAddress
                   r <- runHandshakeServer bearer connId handshakeArgs versions
                   case r of
                     Left (HandshakeProtocolLimit e) -> throwIO e
                     Left (HandshakeProtocolError e) -> throwIO e
                     Right HandshakeQueryResult {}   -> error "handshake query is not supported"
                     Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do
-                      mux <- Mx.new Mx.nullTracers
+                      mux <- Mx.new (connId `Mx.tracersWithBearer` muxTracers)
                                     (toMiniProtocolInfos
-                                      (runForkPolicy noBindForkPolicy (remoteAddress connId))
+                                      (runForkPolicy noBindForkPolicy remoteAddress)
                                       app)
                       withAsync (Mx.run mux bearer) $ \aid -> do
                         void $ simpleMuxCallback connId vNumber vData app mux aid
 
-                errorHandler = \e -> throwIO e
+                errorHandler = \e -> traceWith tracer (ConnectionHandlerException connId e)
+                                  >> throwIO e
             JobPool.forkJob jobPool
                           $ JobPool.Job connThread
                                         errorHandler

ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs

@@ -239,6 +239,8 @@ demo chain0 updates = withIOManager $ \iocp -> do
 
     Server.Simple.with
       (socketSnocket iocp)
+      nullTracer
+      Mx.nullTracers
       makeSocketBearer
       ((. Just) <$> configureSocket)
       producerAddress