Skip to content

Commit 74ba1f3

Browse files
cootcoot
authored
Merge pull request #5224 from IntersectMBO/coot/simple-server-fix
Simple server fix (main)
2 parents 22cb6fb + dbed6ac commit 74ba1f3

File tree

6 files changed

+99
-31
lines changed

6 files changed

+99
-31
lines changed

‎cardano-diffusion/demo/chain-sync.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -276,6 +276,8 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do
276276
Just a -> return (Random.mkStdGen a)
277277
Server.Simple.with
278278
(localSnocket iocp)
279+
nullTracer
280+
Mx.nullTracers
279281
makeLocalBearer
280282
mempty
281283
(localAddressFromPath sockAddr)
@@ -552,6 +554,8 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do
552554
Just a -> return (Random.mkStdGen a)
553555
Server.Simple.with
554556
(localSnocket iocp)
557+
nullTracer
558+
Mx.nullTracers
555559
makeLocalBearer
556560
mempty
557561
(localAddressFromPath sockAddr)

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
### Breaking
2+
3+
- `Ouroboros.Network.Server.Simple.with` now requires tracers as argument,
4+
these should not be nullTracers in production code, although
5+
`Network.Mux.Trace.ChannelTrace` and `Network.Mux.Trace.BearerTrace` should
6+
be off by default as they can be extensive, the `Network.Mux.Trace.Trace` can
7+
be on by default, while `Ouroboros.Network.Server.Simple.ServerTrace` must be
8+
on as it traces important exception.

‎ouroboros-network/demo/ping-pong.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -160,6 +160,8 @@ serverPingPong =
160160
withIOManager $ \iomgr -> do
161161
Server.with
162162
(Snocket.localSnocket iomgr)
163+
nullTracer
164+
Mx.nullTracers
163165
makeLocalBearer
164166
mempty
165167
defaultLocalSocketAddr
@@ -255,6 +257,8 @@ serverPingPong2 =
255257
withIOManager $ \iomgr -> do
256258
Server.with
257259
(Snocket.localSnocket iomgr)
260+
nullTracer
261+
Mx.nullTracers
258262
makeLocalBearer
259263
mempty
260264
defaultLocalSocketAddr

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -240,6 +240,8 @@ prop_socket_send_recv initiatorAddr responderAddr configureSock f xs =
240240
res <-
241241
Server.Simple.with
242242
snocket
243+
nullTracer
244+
Mx.nullTracers
243245
Mx.makeSocketBearer
244246
((. Just) <$> configureSock)
245247
responderAddr

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

Lines changed: 79 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,27 @@
11
{-# LANGUAGE FlexibleContexts #-}
22
{-# LANGUAGE GADTs #-}
33
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
45
{-# LANGUAGE RankNTypes #-}
56
{-# LANGUAGE ScopedTypeVariables #-}
67

78
-- | A simple server. The server doesn't control resource usage (e.g. limiting
89
-- of inbound connections) and thus should only be used in a safe environment.
910
--
1011
-- The module should be imported qualified.
11-
module Ouroboros.Network.Server.Simple where
12+
module Ouroboros.Network.Server.Simple
13+
( with
14+
, ServerTracer (..)
15+
) where
1216

1317
import Control.Applicative (Alternative)
1418
import Control.Concurrent.JobPool qualified as JobPool
15-
import Control.Monad (forever)
1619
import Control.Monad.Class.MonadAsync
1720
import Control.Monad.Class.MonadFork (MonadFork)
1821
import Control.Monad.Class.MonadSTM
1922
import Control.Monad.Class.MonadThrow
2023
import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer)
24+
import Control.Tracer (Tracer, traceWith)
2125
import Data.ByteString.Lazy qualified as BL
2226
import Data.Functor (void)
2327
import Data.Typeable (Typeable)
@@ -28,9 +32,15 @@ import Network.Mux qualified as Mx
2832
import Ouroboros.Network.ConnectionId
2933
import Ouroboros.Network.Mux
3034
import Ouroboros.Network.Protocol.Handshake
31-
import Ouroboros.Network.Snocket as Snocket
35+
import Ouroboros.Network.Server (isECONNABORTED)
36+
import Ouroboros.Network.Snocket (Snocket)
37+
import Ouroboros.Network.Snocket qualified as Snocket
3238
import Ouroboros.Network.Socket
3339

40+
data ServerTracer addr
41+
= AcceptException SomeException
42+
| ConnectionHandlerException (ConnectionId addr) SomeException
43+
deriving Show
3444

3545
with :: forall fd addr vNumber vData m a b.
3646
( Alternative (STM m),
@@ -46,51 +56,89 @@ with :: forall fd addr vNumber vData m a b.
4656
Show vNumber
4757
)
4858
=> Snocket m fd addr
59+
-- ^ low level snocket API
60+
-> Tracer m (ServerTracer addr)
61+
-- ^ server tracer: must not be `nullTracer` in production
62+
-> Mx.TracersWithBearer (ConnectionId addr) m
63+
-- ^ mux tracers
4964
-> Mx.MakeBearer m fd
5065
-> (fd -> addr -> m ())
66+
-- ^ socket configuration for both listening and connection sockets
5167
-> addr
68+
-- ^ server address to bind to
5269
-> HandshakeArguments (ConnectionId addr) vNumber vData m
70+
-- ^ handshake arguments
5371
-> Versions vNumber vData (SomeResponderApplication addr BL.ByteString m b)
72+
-- ^ applications to run on each connection
5473
-> (addr -> Async m Void -> m a)
74+
-- ^ continuation for an internally used `withAsync` function that runs
75+
-- server accept loop
5576
-> m a
56-
with sn makeBearer configureSock addr handshakeArgs versions k =
77+
with sn tracer muxTracers makeBearer configureSock addr handshakeArgs versions k =
5778
JobPool.withJobPool $ \jobPool ->
5879
bracket
5980
(do sd <- Snocket.open sn (Snocket.addrFamily sn addr)
6081
configureSock sd addr
6182
Snocket.bind sn sd addr
6283
Snocket.listen sn sd
63-
addr' <- getLocalAddr sn sd
84+
addr' <- Snocket.getLocalAddr sn sd
6485
pure (sd, addr'))
6586
(Snocket.close sn . fst)
66-
(\(sock, addr') ->
87+
(\(sock, localAddress) ->
6788
-- accept loop
68-
withAsync (forever $ acceptOne jobPool sock) (k addr')
89+
withAsync (Snocket.accept sn sock >>= acceptLoop jobPool localAddress)
90+
(k localAddress)
6991
)
7092
where
71-
acceptOne :: JobPool.JobPool () m () -> fd -> m ()
72-
acceptOne jobPool sock = accept sn sock >>= runAccept >>= \case
73-
(Accepted sock' remoteAddr, _) -> do
74-
let connThread = do
75-
-- connection responder thread
76-
let connId = ConnectionId addr remoteAddr
77-
bearer <- Mx.getBearer makeBearer (-1) sock' Nothing
78-
configureSock sock' addr
79-
r <- runHandshakeServer bearer connId handshakeArgs versions
80-
case r of
81-
Left (HandshakeProtocolLimit e) -> throwIO e
82-
Left (HandshakeProtocolError e) -> throwIO e
83-
Right HandshakeQueryResult {} -> error "handshake query is not supported"
84-
Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do
85-
mux <- Mx.new Mx.nullTracers (toMiniProtocolInfos (runForkPolicy noBindForkPolicy (remoteAddress connId)) app)
86-
withAsync (Mx.run mux bearer) $ \aid -> do
87-
void $ simpleMuxCallback connId vNumber vData app mux aid
93+
acceptLoop :: JobPool.JobPool () m ()
94+
-> addr
95+
-> Snocket.Accept m fd addr
96+
-> m Void
97+
acceptLoop
98+
jobPool
99+
localAddress
100+
Snocket.Accept { Snocket.runAccept }
101+
= do
102+
(accepted, acceptNext) <- runAccept
103+
acceptOne accepted
104+
acceptLoop jobPool
105+
localAddress
106+
acceptNext
107+
where
108+
-- handle accept failures and fork a connection thread which performs
109+
-- a handshake and runs mux
110+
acceptOne :: Snocket.Accepted fd addr -> m ()
111+
acceptOne (Snocket.AcceptFailure e)
112+
| Just ioErr <- fromException e
113+
, isECONNABORTED ioErr
114+
= traceWith tracer (AcceptException e)
115+
acceptOne (Snocket.AcceptFailure e)
116+
= do traceWith tracer (AcceptException e)
117+
throwIO e
88118

89-
errorHandler = \e -> throwIO e
119+
acceptOne (Snocket.Accepted sock' remoteAddress) = do
120+
let connId = ConnectionId { localAddress, remoteAddress }
121+
connThread = do
122+
-- connection responder thread
123+
bearer <- Mx.getBearer makeBearer (-1) sock' Nothing
124+
configureSock sock' localAddress
125+
r <- runHandshakeServer bearer connId handshakeArgs versions
126+
case r of
127+
Left (HandshakeProtocolLimit e) -> throwIO e
128+
Left (HandshakeProtocolError e) -> throwIO e
129+
Right HandshakeQueryResult {} -> error "handshake query is not supported"
130+
Right (HandshakeNegotiationResult (SomeResponderApplication app) vNumber vData) -> do
131+
mux <- Mx.new (connId `Mx.tracersWithBearer` muxTracers)
132+
(toMiniProtocolInfos
133+
(runForkPolicy noBindForkPolicy remoteAddress)
134+
app)
135+
withAsync (Mx.run mux bearer) $ \aid -> do
136+
void $ simpleMuxCallback connId vNumber vData app mux aid
90137

91-
JobPool.forkJob jobPool
92-
$ JobPool.Job connThread
93-
errorHandler
94-
()
95-
"conn-thread"
96-
(AcceptFailure e, _) -> throwIO e
138+
errorHandler = \e -> traceWith tracer (ConnectionHandlerException connId e)
139+
>> throwIO e
140+
JobPool.forkJob jobPool
141+
$ JobPool.Job connThread
142+
errorHandler
143+
()
144+
"conn-thread"

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -239,6 +239,8 @@ demo chain0 updates = withIOManager $ \iocp -> do
239239

240240
Server.Simple.with
241241
(socketSnocket iocp)
242+
nullTracer
243+
Mx.nullTracers
242244
makeSocketBearer
243245
((. Just) <$> configureSocket)
244246
producerAddress

0 commit comments

Comments
 (0)