From 0af76f647ab48953c2a568ac4986069ca50b681d Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 28 Jan 2025 10:31:25 +0100 Subject: [PATCH] Label internal Windows hack thread Co-authored-by: Felix Paulusma --- warp/Network/Wai/Handler/Warp/Windows.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/warp/Network/Wai/Handler/Warp/Windows.hs b/warp/Network/Wai/Handler/Warp/Windows.hs index 575c7b17d..4a44853c9 100644 --- a/warp/Network/Wai/Handler/Warp/Windows.hs +++ b/warp/Network/Wai/Handler/Warp/Windows.hs @@ -10,6 +10,7 @@ import Control.Concurrent import qualified Control.Exception import Network.Wai.Handler.Warp.Imports +import GHC.Conc (labelThread) -- | Allow main socket listening thread to be interrupted on Windows platform -- @@ -18,7 +19,8 @@ windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack act = do var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a)) -- Catch and rethrow even async exceptions, so don't bother with UnliftIO - void . forkIO $ Control.Exception.try act >>= putMVar var + threadId <- forkIO $ Control.Exception.try act >>= putMVar var + labelThread threadId "Windows Thread Block Hack (warp)" res <- takeMVar var case res of Left e -> Control.Exception.throwIO e