From c46f93775fb723ce33a15bc79e03e5509b170beb Mon Sep 17 00:00:00 2001 From: Romain GERARD Date: Sun, 11 Dec 2022 21:08:18 +0100 Subject: [PATCH] fix udp server dying due to BlockedIndefinitelyOnMVar Former-commit-id: 3b196ad1dd251da10a16ba92c6b406dd82bc14a2 Former-commit-id: 22ff60708b7918aecd12d6e6d38356c63bb5a567 [formerly c4e7cd099079d7728cf28c2d08e068a5995850c9] [formerly f6cf0c8536ef624a6252bfabd870740614a9677a [formerly 261f59a6a33f78d86b7d555905cf9a55ec2eedeb [formerly e6f63f7fc005ad2dab36b304114d2568c2d63cd4] [formerly e6f63f7fc005ad2dab36b304114d2568c2d63cd4 [formerly e6f63f7fc005ad2dab36b304114d2568c2d63cd4 [formerly 4202be87d212a1939cb57502630a4d0eb7ec0c26]]]]] Former-commit-id: aaa73da1686f57961be57ad6aa8476b3895ecac5 [formerly 704971dfb9ef961f0b43376f221d21d22dd2fffa] Former-commit-id: b21cd9564e59374361b81e7557c324eae4eb6661 Former-commit-id: f3a7e81c15358d470608639714ec87a65d5bbbf6 Former-commit-id: 52494e1883d95d60395e5d062846a3dcc2e39e7b Former-commit-id: 845cb1c441d4301fa56dd9ebd71c6a7be158a7bc [formerly 734bf85e5391d55a2243b5857870824b264c36e0] Former-commit-id: 4b82bfe4dabde5f2101f71f055e0949800d7807b --- src/Protocols.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Protocols.hs b/src/Protocols.hs index 5aa5941..529f340 100644 --- a/src/Protocols.hs +++ b/src/Protocols.hs @@ -4,7 +4,7 @@ module Protocols where import ClassyPrelude -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO, forkFinally, threadDelay) import qualified Data.HashMap.Strict as H import System.IO hiding (hSetBuffering, hGetBuffering) @@ -71,7 +71,7 @@ runUDPServer :: (HostName, PortNumber) -> Int -> (UdpAppData -> IO ()) -> IO () runUDPServer endPoint@(host, port) cnxTimeout app = do info $ "WAIT for datagrames on " <> toStr endPoint clientsCtx <- newIORef mempty - void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (runEventLoop clientsCtx) + void $ bracket (N.bindPortUDP (fromIntegral port) (fromString host)) N.close (forever . run clientsCtx) info $ "CLOSE udp server" <> toStr endPoint where @@ -98,6 +98,14 @@ runUDPServer endPoint@(host, port) cnxTimeout app = do -- and will leave us waiting forever for the mutex to empty. So catch the exeception and drop the message. -- Udp is not a reliable protocol so transmission failure should be handled by the application layer + -- We run the server inside another thread in order to avoid Haskell runtime sending to the main thread + -- the exception BlockedIndefinitelyOnMVar + -- We dont use also MVar to wait for the end of the thread to avoid also receiving this exception + run :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO () + run clientsCtx socket = do + _ <- forkFinally (runEventLoop clientsCtx socket) (\_ -> debug "UdpServer died") + threadDelay (maxBound :: Int) + runEventLoop :: IORef (H.HashMap N.SockAddr UdpAppData) -> N.Socket -> IO () runEventLoop clientsCtx socket = forever $ do (payload, addr) <- N.recvFrom socket 4096 @@ -105,10 +113,10 @@ runUDPServer endPoint@(host, port) cnxTimeout app = do case clientCtx of Just clientCtx' -> pushDataToClient clientCtx' payload - _ -> void . forkIO $ bracket - (addNewClient clientsCtx socket addr payload) - (removeClient clientsCtx) - (void . timeout cnxTimeout . app) + _ -> do + clientCtx <- addNewClient clientsCtx socket addr payload + _ <- forkFinally (void . timeout cnxTimeout $ app clientCtx) (\_ -> removeClient clientsCtx clientCtx) + return () runSocks5Server :: Socks5.ServerSettings -> TunnelSettings -> (TunnelSettings -> N.AppData -> IO()) -> IO ()