如何在不终止yesod-websocket连接时停止监听并实现循环启停？

嘿，我懂你要实现的这个需求——用Yesod-WebSockets做一个支持启停控制的后台数据推送服务：收到"Start"指令就启动线程持续生成数据发给客户端，不管是客户端发"Stop"叫停，还是生产者自己因业务逻辑停止，都得自动回到主循环等待下一次"Start"指令对吧？下面给你整理了可运行的代码示例，还加了关键逻辑的注释，方便你理解和调整：

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

import Yesod
import Yesod.WebSockets
import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Concurrent.MVar (newMVar, takeMVar, putMVar, readMVar)
import Control.Concurrent.STM (TChan, newTChanIO, writeTChan, readTChan, atomically)
import Control.Monad (forever, when, void)
import Data.Text (Text, pack)

data App = App

mkYesod "App" [parseRoutes|
/ HomeR GET
/ws WebSocketR WebSocket
|]

instance Yesod App

getHomeR :: Handler Html
getHomeR = defaultLayout $ do
    setTitle "Yesod WebSocket 启停测试"
    toWidget [julius|
        const ws = new WebSocket(`ws://${window.location.host}/ws`);
        ws.onmessage = e => console.log('收到数据:', e.data);
        
        // 添加测试按钮
        const startBtn = document.createElement('button');
        startBtn.textContent = '启动推送';
        startBtn.onclick = () => ws.send('Start');
        
        const stopBtn = document.createElement('button');
        stopBtn.textContent = '停止推送';
        stopBtn.onclick = () => ws.send('Stop');
        
        document.body.append(startBtn, ' ', stopBtn);
    |]

webSocketHandler :: WebSocketsT Handler ()
webSocketHandler = forever $ do
    -- 等待客户端发送指令
    cmd <- receiveData
    case cmd of
        "Start" -> do
            -- 创建停止标志（控制生产者线程）和消息通道（线程安全传递数据）
            stopFlag <- liftIO $ newMVar False
            dataChan <- liftIO $ newTChanIO
            
            -- 启动数据生产者线程
            liftIO $ forkIO $ producer dataChan stopFlag
            
            -- 启动独立的消息发送线程（从通道取数据发给客户端，保证线程安全）
            sendThreadId <- liftIO $ forkIO $ forever $ do
                msg <- atomically $ readTChan dataChan
                runWebSocketsT (sendTextData msg) webSocketHandler
            
            -- 进入等待停止的子循环，直到收到停止指令或生产者自行结束
            waitForStop stopFlag sendThreadId
        "Stop" -> sendTextData "当前没有运行的推送，请先发送Start指令"
        _ -> sendTextData "未知指令，请发送Start或Stop"
  where
    -- 生产者函数：持续生成数据，直到收到停止信号
    producer dataChan stopFlag = forever $ do
        threadDelay 1000000 -- 模拟每秒生成一次数据，可替换为你的业务逻辑
        shouldStop <- readMVar stopFlag
        if shouldStop
            then return ()
            else do
                -- 这里替换成你的实际数据生成逻辑
                let generatedData = pack $ "实时数据：" ++ show (length "自定义业务内容")
                atomically $ writeTChan dataChan generatedData
        -- 再次检查停止状态，满足则退出循环
        shouldStop <- readMVar stopFlag
        when shouldStop $ return ()
    
    -- 等待停止指令，处理停止逻辑
    waitForStop stopFlag sendThreadId = do
        cmd <- receiveData
        case cmd of
            "Stop" -> do
                liftIO $ putMVar stopFlag True
                liftIO $ killThread sendThreadId -- 终止发送线程
                sendTextData "推送已停止，等待下一条Start指令"
            _ -> do
                sendTextData "当前正在推送，请发送Stop指令停止"
                waitForStop stopFlag sendThreadId -- 忽略其他指令，继续等待停止信号

getWebSocketR :: Handler ()
getWebSocketR = webSocket webSocketHandler

main :: IO ()
main = warp 3000 App

关键逻辑说明 #

• 线程安全保障：用TChan传递生产者生成的数据，避免直接在生产者线程中调用WebSocket发送函数（WebSocket的send操作并非线程安全）
• 启停状态控制：通过MVar存储停止标志，生产者每秒检查一次状态，收到停止信号就自动退出；主线程收到"Stop"指令后更新标志并终止发送线程
• 自动恢复机制：无论主动停止还是生产者因业务逻辑自行结束，waitForStop子循环结束后都会回到外层的forever主循环，等待下一次"Start"指令
• 用户友好提示：对错误指令、重复启停操作都添加了提示信息，提升客户端交互体验

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