From c3dcf45bdaaffbb5acc6a60067304ac650a6745a Mon Sep 17 00:00:00 2001 From: Karl Knutsson Date: Tue, 17 Aug 2021 12:59:12 +0000 Subject: [PATCH] Monitor acceptLoopDo Previusly exceptions thrown by acceptLoopDo was ignored. Change it so that if either accept loop or main loop throws an exception they are both killed and the exception rethrown. --- .../src/Ouroboros/Network/Server/Socket.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs index 45676dc36e1..73c9364f3cf 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs @@ -288,12 +288,12 @@ run errroPolicyTrace acceptPolicyTrace socket acceptedConnectionLimit acceptExce resQ <- STM.newTQueueIO threadsVar <- STM.newTVarIO Set.empty let acceptLoopDo = acceptLoop acceptPolicyTrace resQ threadsVar statusVar acceptedConnectionLimit beginConnection applicationStart acceptException socket - -- The accept loop is killed when the main loop stops. - mainDo = Async.withAsync acceptLoopDo $ \_ -> - mainLoop errroPolicyTrace resQ threadsVar statusVar complete main + -- The accept loop is killed when the main loop stops and the main + -- loop is killed if the accept loop stops. + mainDo = mainLoop errroPolicyTrace resQ threadsVar statusVar complete main killChildren = do children <- STM.atomically $ STM.readTVar threadsVar forM_ (Set.toList children) Async.cancel -- After both the main and accept loop have been killed, any remaining -- spawned threads are cancelled. - mainDo `finally` killChildren + (snd <$> Async.concurrently acceptLoopDo mainDo) `finally` killChildren