Label internal Windows hack thread

yesodweb · Jan 24, 2025 · eebc207 · eebc207
1 parent 6e9c862
commit eebc207
Showing 1 changed file with 4 additions and 1 deletion.
diff --git 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,9 @@ 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
+    void . forkIO $ do
+      myThreadId >>= flip labelThread "Windows Thread Block Hack (warp)"
+      Control.Exception.try act >>= putMVar var
     res <- takeMVar var
     case res of
       Left  e -> Control.Exception.throwIO e