Haskell Telnet控制台STM TVar写入操作未生效问题求助

嗨，我仔细看了你的代码，发现导致状态无法保存的核心问题出在TVar的传递方式上！

你当前把STM (TVar Störm)作为talk函数的参数，但实际上每次调用talk state' s时，state'是newTVar Aus这个STM动作——每次执行这个STM都会创建一个全新的TVar实例！这就意味着你每次修改的都是临时的新TVar，下次查询状态时又会创建另一个新的TVar，自然永远返回默认的Aus。

解决方案：传递已创建的TVar实例 #

我们需要先一次性创建好TVar，然后把这个实例传给talk函数，而不是传递创建TVar的STM动作。具体修改步骤如下：

1. 修改someFunc，预先创建TVar
   先通过atomically执行newTVar Aus得到TVar实例，再传给talk：

   someFunc :: IO ()
   someFunc = do
     state <- atomically $ newTVar Aus
     runTCPServer Nothing "3000" (talk state)
   

2. 调整talk的类型签名和内部逻辑
   让talk接收TVar Störm类型的参数，直接操作这个已存在的TVar：

   talk :: TVar Störm -> Socket -> IO ()
   talk state s = recv s 1024 >>= \msg -> unless (S.null msg) $
     case C.unpack msg of
       "exit\r\n" -> sendAll s (C.pack "Auf Widerhoren")
       "an\r\n" -> do
         sendAll s (C.pack "Am An\n")
         putStrLn "Am An"
         write state An
         talk state s
       "aus\r\n" -> do
         sendAll s (C.pack "Am Aus\n")
         putStrLn "Am Aus"
         write state Aus
         talk state s
       "anzeigen\r\n" -> do
         currentState <- atomically $ readTVar state
         sendAll s (C.pack $ show currentState)
         putStrLn "Am Anzeigen State"
         talk state s
       otherwise -> do
         sendAll s (C.pack "Unbekannte Befehl\n")
         putStrLn (show msg)
         talk state s
   

3. 简化write函数
   现在直接接收TVar实例，不需要再处理STM动作：

   write :: TVar Störm -> Störm -> IO ()
   write state new = atomically $ writeTVar state new
   

修改后的完整代码 #

module Main (main) where

import qualified Data.ByteString.Char8 as C
import Control.Concurrent (forkFinally)
import qualified Control.Exception as E
import Control.Monad (unless, forever, void)
import Control.Monad.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, newTVar, writeTVar, readTVar)
import qualified Data.ByteString as S
import Network.Socket (close, setSocketOption)
import Network.Socket (HostName)
import Network.Socket (ServiceName, AddrInfo)
import Network.Socket (Socket, SocketType(Stream))
import Network.Socket (addrFlags, getAddrInfo, gracefulClose, accept, listen, addrAddress, bind, setCloseOnExecIfNeeded, openSocket, withFdSocket, SocketOption(ReuseAddr))
import Network.Socket (addrSocketType, defaultHints, AddrInfoFlag(AI_PASSIVE))
import Network.Socket.ByteString (recv, sendAll)

data Störm = An | Aus deriving Show

someFunc :: IO ()
someFunc = do
  state <- atomically $ newTVar Aus
  runTCPServer Nothing "3000" (talk state)

talk :: TVar Störm -> Socket -> IO ()
talk state s = recv s 1024 >>= \msg -> unless (S.null msg) $
  case C.unpack msg of
    "exit\r\n" -> sendAll s (C.pack "Auf Widerhoren")
    "an\r\n" -> do
      sendAll s (C.pack "Am An\n")
      putStrLn "Am An"
      write state An
      talk state s
    "aus\r\n" -> do
      sendAll s (C.pack "Am Aus\n")
      putStrLn "Am Aus"
      write state Aus
      talk state s
    "anzeigen\r\n" -> do
      currentState <- atomically $ readTVar state
      sendAll s (C.pack $ show currentState)
      putStrLn "Am Anzeigen State"
      talk state s
    otherwise -> do
      sendAll s (C.pack "Unbekannte Befehl\n")
      putStrLn (show msg)
      talk state s

write :: TVar Störm -> Störm -> IO ()
write state new = atomically $ writeTVar state new

runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
runTCPServer mhost port server = resolve >>= \addr -> (E.bracket (open addr) close loop)
  where
    resolve :: IO AddrInfo
    resolve = do
      let hints = defaultHints {
              addrFlags = [AI_PASSIVE]
            , addrSocketType = Stream
            }
      head <$> getAddrInfo (Just hints) mhost (Just port)
    open :: AddrInfo -> IO Socket
    open addr = E.bracketOnError (openSocket addr) close $ \sock -> do
      setSocketOption sock ReuseAddr 1
      withFdSocket sock setCloseOnExecIfNeeded
      bind sock $ addrAddress addr
      listen sock 1024
      return sock
    loop :: Socket -> IO b0
    loop sock = forever $ E.bracketOnError (accept sock) (close . fst)
      $ \(conn, _peer) -> void $
          forkFinally (server conn) (const $ gracefulClose conn 5000)

这样修改后，所有的客户端连接都会共享同一个TVar实例（如果需要每个客户端独立状态的话，你可以把TVar的创建移到server conn的逻辑里，但看起来你是想要全局状态），执行an或aus后，再用anzeigen就能正确显示当前状态了。

备注：内容来源于stack exchange，提问作者Erdel von Mises