naming threads

Network/QUIC/Common.hs

@@ -4,6 +4,9 @@ module Network.QUIC.Common where
 
 import qualified Network.Socket as NS
 
+import Control.Concurrent
+import GHC.Conc.Sync
+
 import Network.QUIC.Connection
 import Network.QUIC.Parameters
 import Network.QUIC.Types
@@ -22,3 +25,11 @@ defaultPacketSize _ = defaultQUICPacketSizeForIPv4
 maximumPacketSize :: NS.SockAddr -> Int
 maximumPacketSize NS.SockAddrInet6{} = 1500 - 40 - 8 -- fixme
 maximumPacketSize _ = 1500 - 20 - 8 -- fixme
+
+labelMe :: String -> IO ()
+labelMe name = do
+    tid <- myThreadId
+    mlabel <- threadLabel tid
+    case mlabel of
+        Nothing -> labelThread tid name
+        Just _ -> return ()

Network/QUIC/Server/Reader.hs

@@ -32,6 +32,7 @@ import Network.Socket (Socket)
 import qualified Network.Socket.ByteString as NSB
 import qualified System.IO.Error as E
 
+import Network.QUIC.Common
 import Network.QUIC.Config
 import Network.QUIC.Connection
 import Network.QUIC.Exception
@@ -59,7 +60,11 @@ newDispatch ServerConfig{..} =
         <*> newIORef emptyRecvQDict
         <*> newAcceptQ
   where
-    conf = CT.defaultConfig{CT.tokenLifetime = scTicketLifetime}
+    conf =
+        CT.defaultConfig
+            { CT.tokenLifetime = scTicketLifetime
+            , CT.threadName = "QUIC token manager"
+            }
 
 clearDispatch :: Dispatch -> IO ()
 clearDispatch d = CT.killTokenManager $ tokenMgr d
@@ -144,6 +149,7 @@ runDispatcher d conf mysock = forkIO $ dispatcher d conf mysock
 
 dispatcher :: Dispatch -> ServerConfig -> Socket -> IO ()
 dispatcher d conf mysock = handleLogUnit logAction $ do
+    labelMe "QUIC dispatcher"
     forever $ do
         (peersa, bs, cmsgs, _) <- safeRecv $ NSB.recvMsg mysock 2048 2048 0
         now <- getTimeMicrosecond

Network/QUIC/Server/Run.hs

@@ -41,6 +41,7 @@ import Network.QUIC.Types
 --   in a new lightweight thread.
 run :: ServerConfig -> (Connection -> IO ()) -> IO ()
 run conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do
+    labelMe "QUIC run"
     baseThreadId <- myThreadId
     E.bracket setup teardown $ \(dispatch, _, _) -> do
         onServerReady $ scHooks conf
@@ -68,6 +69,7 @@ run conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do
 --   in a new lightweight thread.
 runWithSockets :: [NS.Socket] -> ServerConfig -> (Connection -> IO ()) -> IO ()
 runWithSockets ssas conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do
+    labelMe "QUIC runWithSockets"
     baseThreadId <- myThreadId
     E.bracket setup teardown $ \(dispatch, _) -> do
         onServerReady $ scHooks conf
@@ -92,7 +94,8 @@ runWithSockets ssas conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do
 -- And the exception should be ignored.
 runServer
     :: ServerConfig -> (Connection -> IO ()) -> Dispatch -> ThreadId -> Accept -> IO ()
-runServer conf server0 dispatch baseThreadId acc =
+runServer conf server0 dispatch baseThreadId acc = do
+    labelMe "QUIC runServer"
     E.bracket open clse $ \(ConnRes conn myAuthCIDs _reader) ->
         handleLogUnit (debugLog conn) $ do
             let conf' =