Haskell STM不给出输出或派生Show不给出任何输出

xwmevbvl  于 2023-10-19  发布在  其他
关注(0)|答案(1)|浏览(147)

我正在用haskell编写一个telnet控制台,代码如下

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 (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 = runTCPServer Nothing "3000" (talk $ newTVar Aus)
  where
    talk :: STM (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" -> sendAll s (C.pack "Am An\n") >> putStrLn "Am An" >> write state' An >> talk state' s
        "aus\r\n" -> sendAll s (C.pack "Am Aus\n") >> putStrLn "Am Aus" >> write state' Aus >> talk state' s
        "anzeigen\r\n" -> sendAll s <$> (atomically $ C.pack <$> show <$> (state' >>= readTVar)) >> putStrLn "Am Anzeigen State" >> talk state' s
        otherwise -> sendAll s (C.pack "Unbekannte Befehl\n") >> putStrLn (show msg) >> (talk (state') s)
    write :: STM (TVar Störm) -> Störm -> IO ()
    write state new = atomically $ state >>= \s -> writeTVar s 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' alone is unlikely to fail thus leaking @conn@,
            -- but 'E.bracketOnError' above will be necessary if some
            -- non-atomic setups (e.g. spawning a subprocess to handle
            -- @conn@) before proper cleanup of @conn@ is your case
            forkFinally (server conn) (const $ gracefulClose conn 5000)

它使用了

base ^>=4.16.4.0
                    , network ^>=3.1.4.0
                    , bytestring
                    , stm

当从telnet会话连接到telnet到控制台,并运行anaus,然后anzeigen或直接运行时,控制台不会向telnet客户端返回相应的AnAus消息,而只是一个空格,同时我知道该情况是正确选择的,因为消息Am Anzeigen State显示在服务器的标准输出中。
我不知道为什么会这样。

guykilcj

guykilcj1#

问题是你什么都没发。
在“anzeigen”处理程序中,有以下代码(重命名为partThatDoesntMatter = (atomically $ C.pack <$> show <$> (state' >>= readTVar))

sendAll s <$> partThatDoesntMatter >> putStrLn "Am Anzeigen State"

这只是

fmap (sendAll s) partThatDoesntMatter >> putStrLn "Am Anzeigen State"

你想在这里使用sendAll发送一些东西,但是你在这里的fmap调用只是产生了一个永远不会被执行的sendAll动作(之后会立即被>>丢弃)。
你需要的是

partThatDoesntMatter >>= sendAll s >> putStrLn "Am Anzeigen State"

比较:

fmap :: (a -> b) -> m a -> m b
(>>=) :: m a -> (a -> m b) -> m b

应用到我们的例子中,这是

sendAll s :: ByteString -> IO ()
partThatDoesntMatter :: IO ByteString
fmap (sendAll s) partThatDoesntMatter :: IO (IO ())
partThatDoesntMatter >>= sendAll s :: IO ()

相关问题