Haskell多线程聊天客户端执行quit()后无法立即终止的问题

在Windows 10的GHCi 9.4.5环境下，编写的Haskell聊天客户端/服务端程序存在退出异常：输入quit()后，客户端显示"####### Left Chat #######"但进程不立即终止，需等其他用户发送消息才结束。推测killThread没能终止clientListener线程，求问题原因、解决方法及额外运行建议。

客户端代码 #

import Network.Socket
import Control.Monad
import Control.Concurrent
import System.IO
import Control.Monad.Fix

connectToChatRoom :: IO ()
connectToChatRoom = do
    addrinfos <- getAddrInfo
                    Nothing
                    (Just "localhost")
                    (Just "9999")
    let serveraddr = head addrinfos
    serverSock <- socket (addrFamily serveraddr) Stream defaultProtocol
    connect serverSock (addrAddress serveraddr)
    hdl <- socketToHandle serverSock ReadWriteMode   -- make a handle
    hSetBuffering hdl NoBuffering
    listenThread <- forkIO (clientListener hdl)  -- open a new thread that listens
    clientSender hdl -- this thread now sends messages
    putStrLn "####### Left Chat #######"
    killThread listenThread        
    close serverSock

clientSender :: Handle -> IO ()
clientSender hdl = fix $ \loop -> do
    msg <- getLine -- read message from user
    when (msg /= "quit()") $ hPutStrLn hdl msg >> loop -- if not "quit()" send msg and continue looping


clientListener :: Handle -> IO ()
clientListener hdl = fix $ \loop -> do
    msg <- hGetLine hdl -- listen for msg from server
    putStrLn msg -- print to stdout
    loop

服务端代码 #

type Msg = (ID, String)
type ID = Int

chatRoomServer :: IO ()
chatRoomServer = do
    addrinfos <- getAddrInfo
                    (Just (defaultHints {addrFlags = [AI_PASSIVE]}))
                    Nothing
                    (Just "9999")
    let serveraddr = head addrinfos
    sock <- socket (addrFamily serveraddr) Stream defaultProtocol -- make socket
    bind sock (addrAddress serveraddr) -- bind socket to port
    listen sock 1 -- set up socket listener
    chan <- newChan
    _ <- forkIO $ fix $ \loop -> do -- in a tutorial, something about reading the initial channel
      (_, _) <- readChan chan
      loop
    listenForConnections sock chan -- loops waiting to accept connections

listenForConnections :: Socket -> Chan Msg -> IO ()
listenForConnections sock chan = fix loop_ 1
    where loop_ loop idNum = do
            (clientSock, _) <- accept sock
            _ <- forkIO $ manageConnection clientSock idNum chan
            loop (idNum + 1)


manageConnection :: Socket -> ID -> Chan Msg -> IO ()
manageConnection sock idNum chan = do
    let broadcast msg = writeChan chan msg -- send message to all users
    hdl <- socketToHandle sock ReadWriteMode
    hSetBuffering hdl NoBuffering
    commline <- dupChan chan
    _ <- forkIO $ fix $ \loop -> do -- listen for msg to user
        (idNum', msg) <- readChan commline
        when (idNum' /= idNum) $ hPutStrLn hdl ("From User " ++ show idNum' ++ ": " ++ msg)
        loop
    fix $ \loop -> do    -- listen for msg from user
        msg <- hGetLine hdl
        broadcast (idNum, msg)
        loop

1. killThread的局限性：killThread会向目标线程抛出ThreadKilled异常，但如果线程处于阻塞系统调用（比如hGetLine等待服务器消息）时，Windows系统下该异常不会立即触发，必须等系统调用返回后才会处理异常。这就是为什么只有当其他用户发消息（让hGetLine返回）后，线程才会响应终止信号。
2. 资源关闭顺序错误：客户端现有逻辑是先调用killThread再关闭socket/handle，但此时clientListener线程还在阻塞于hGetLine，关闭资源的操作无法中断这个阻塞调用，导致线程无法及时退出。

客户端修复方案 #

核心思路是先关闭连接资源，再终止线程，利用资源关闭触发hGetLine抛出异常，让线程自然退出，无需依赖killThread的强制终止：

connectToChatRoom :: IO ()
connectToChatRoom = do
    addrinfos <- getAddrInfo
                    Nothing
                    (Just "localhost")
                    (Just "9999")
    let serveraddr = head addrinfos
    serverSock <- socket (addrFamily serveraddr) Stream defaultProtocol
    connect serverSock (addrAddress serveraddr)
    hdl <- socketToHandle serverSock ReadWriteMode
    hSetBuffering hdl NoBuffering
    listenThread <- forkIO (clientListener hdl)
    clientSender hdl
    putStrLn "####### Left Chat #######"
    hClose hdl  -- 先关闭handle，触发hGetLine抛出IO异常
    killThread listenThread  -- 兜底确保线程完全终止
    close serverSock

-- 修改clientListener，捕获IO异常实现优雅退出
clientListener :: Handle -> IO ()
clientListener hdl = fix $ \loop -> do
    result <- try (hGetLine hdl) :: IO (Either IOError String)
    case result of
        Right msg -> putStrLn msg >> loop
        Left _ -> return ()  -- 连接关闭时直接退出循环

说明：

• hClose hdl会立即中断hGetLine的阻塞状态，抛出IOError，线程捕获异常后直接退出，无需等待外部消息。
• 使用try捕获IO异常，避免线程因异常崩溃，保证退出流程的优雅性。

服务端配套优化 #

当前服务端在客户端退出后，manageConnection中的读线程会一直阻塞在hGetLine，造成资源浪费。可以同步修改服务端的消息读取逻辑，捕获连接关闭的异常：

manageConnection :: Socket -> ID -> Chan Msg -> IO ()
manageConnection sock idNum chan = do
    let broadcast msg = writeChan chan msg
    hdl <- socketToHandle sock ReadWriteMode
    hSetBuffering hdl NoBuffering
    commline <- dupChan chan
    _ <- forkIO $ fix $ \loop -> do
        (idNum', msg) <- readChan commline
        when (idNum' /= idNum) $ do
            result <- try (hPutStrLn hdl ("From User " ++ show idNum' ++ ": " ++ msg)) :: IO (Either IOError ())
            case result of
                Right _ -> loop
                Left _ -> return ()  -- 客户端断开则退出广播线程
    fix $ \loop -> do
        result <- try (hGetLine hdl) :: IO (Either IOError String)
        case result of
            Right msg -> broadcast (idNum, msg) >> loop
            Left _ -> hClose hdl  -- 客户端断开则关闭资源并退出

• 优先使用协作式线程终止：尽量通过资源关闭、信号通知等方式让线程自行退出，killThread属于强制终止，容易引发资源泄漏或状态不一致问题。
• 全覆盖IO异常处理：所有网络、文件类IO操作都要捕获异常，网络场景中连接断开、超时等情况非常常见，未处理的异常会导致线程崩溃。
• 设置Socket超时：在Windows环境下，可给Socket设置超时时间，避免线程无限期阻塞。例如添加setSocketOption sock RecvTimeout 5000（单位毫秒），让hGetLine在超时后自动抛出异常。
• 调整服务端监听队列：当前服务端listen sock 1设置的监听队列长度为1，限制了同时等待连接的客户端数量，建议调整为更大的值（比如5），方便测试多用户聊天场景。
• GHCi运行技巧：在GHCi中运行多线程程序时，若进程无法正常终止，可使用:kill命令强制结束所有线程，避免残留进程占用端口。

内容的提问来源于stack exchange，提问作者Tristan