如何在Haskell中测试Web套接字

使用haskell测试WebSocket的建议方法

我在一个websockets服务器上工作，我一直在使用websockets库，在实现我的服务器时没有遇到任何问题。我遇到的问题与服务器的测试有关

我想打开一个双向通信通道，该通道存在于我为测试而生成的每个

ClientApp

中。这使我能够轻松控制客户端发送到服务器的内容，并检索响应，以便在我的hspec测试中使用。我的第一个实现使用了MVar，效果很好，但是一个Chan或TChan确实是一个更适合这个目的的结构

我在执行TChan时遇到困难，我相信这与我如何执行导致程序停止的STM事务有关。不幸的是，我无法通过简单的打印调试来解决这个问题

我创建了一个伪单元测试，它实现了一些类似的逻辑，并且在该测试中运行良好（这显然意味着它是一个糟糕的测试）

下面是一个简单的echo服务器，用于重现问题以及基于MVar和TChan的测试

我希望我能得到一些帮助，这将是一个很好的办法，我相信我的做法是天真的。如有任何建议，我们将不胜感激。所有的runIO和阻塞代码似乎都应该使用async库来实现更干净的接口

该程序可以使用ghcid运行，它将在重新加载之间终止并重新启动服务器

ghcid命令：

ghcpid=$(pgrep ghc)
if [ -z "$ghcpid" ]
killall -9 ghc
then 
    echo "No GHC process Found"
    ghcid  --command "stack ghci HaskSockets:lib HaskSockets:HaskSockets-test --ghci-options=-fobject-code" --test "Spec.main"
else
    echo $ghcpid
    kill $ghcpid
    ghcid  --command "stack ghci HaskSockets:lib HaskSockets:HaskSockets-test --ghci-options=-fobject-code" --test "Spec.main"
fi

module-DevelMain
（主要
，问候语（…）
，讯息（…）
)在哪里
导入数据。文本（Text）
导入控制。异常（最终）
导入控制.Monad（表单，永远）
导入控制.Concurrent（MVar、newMVar、modifyMVar、modifyMVar、readMVar、takeMVar、ThreadId（..）和putMVar）
导入符合条件的数据。文本为T
将限定的Data.Text.IO作为T导入
将合格的Network.WebSockets作为WS导入
导入符合条件的Data.HashMap.Strict作为HM
导入控制.Concurrent.Async
导入数据.Aeson
类型Client=（文本，WS.Connection）
类型ServerState=[Client]
数据问候语=问候语
{问候语：：文本
}推导（等式，显示）
实例FromJSON问候语，其中
parseJSON（对象o）=do
g服务器状态->布尔
clientExists client=any（==fst client.fst）
addClient:：Client->ServerState->ServerState
addClient=client:clients
removeClient:：Client->ServerState->ServerState
removeClient client=filter（（/=fst client）.fst）
广播：：文本->服务器状态->IO（）
广播消息客户端=do
表格\uuClients$\（康涅狄格州北部）->do
T.putStrLn消息
WS.sendTextData连接消息
main:：MVar（）->IO（）
主压井=do
state WS.ServerApp
应用程序状态挂起=do
康涅狄格州
让s'=removeClient客户端s
报税表
对话：：客户端->MVar服务器状态->IO（）
通话（用户，康涅狄格州）状态=永久$do
msg>=广播消息

模块规格，其中
导入控制.Concurrent（forkIO、threadDelay、killThread、ThreadId）
导入控制.Concurrent.MVar
进口管制.Concurrent.Chan
进口控制。单子（永久，除非）
进口控制单体转运（liftIO）
导入网络套接字（带socketsdo）
导入数据。文本（Text）
导入符合条件的数据。文本为T
将限定的Data.Text.IO作为T导入
将合格的Network.WebSockets作为WS导入
进口合格的DevelMain
导入DevelMain（消息（..），问候语（..）
进口测试
导入数据.Word
进口外国货
导入Data.ByteString.Lazy（ByteString（..）
导入数据.Aeson
导入控制.Concurrent.STM.TChan
导入控制.Monad.STM
将合格的MVarController作为MVC导入
将合格的TCH控制器作为TCC导入
threadStoreIndex:：Word32
threadStoreIndex=1
main:：IO（）
main=do
mthreaddo
打印“无存储线程”
杀死
module DevelMain
    ( main
    , Greeting(..)
    , Message(..)
    ) where

import Data.Text (Text)
import Control.Exception (finally)
import Control.Monad (forM_, forever)
import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar, takeMVar, ThreadId(..), putMVar)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Network.WebSockets as WS
import qualified Data.HashMap.Strict as HM 
import Control.Concurrent.Async
import Data.Aeson

type Client = (Text, WS.Connection)
type ServerState = [Client]

data Greeting = Greeting
  { greeting :: Text
  } deriving (Eq, Show)

instance FromJSON Greeting where
  parseJSON (Object o) = do
   g <- o .: "greeting"
   return $ Greeting g

instance ToJSON Greeting where 
  toJSON (Greeting g) = object 
    [ "greeting" .= g
    ]

data Message = Message
  { message :: Text
  } deriving (Eq, Show)

instance FromJSON Message where
  parseJSON (Object o) = do
   m <- o .: "message"
   return $ Message m

instance ToJSON Message where 
  toJSON (Message m) = object 
    [ "message" .= m
    ]

newServerState :: ServerState
newServerState = []

numClients :: ServerState -> Int
numClients = length

clientExists :: Client -> ServerState -> Bool
clientExists client = any ((== fst client) . fst)

addClient :: Client -> ServerState -> ServerState
addClient client clients = client : clients

removeClient :: Client -> ServerState -> ServerState
removeClient client = filter ((/= fst client) . fst)

broadcast :: Text -> ServerState -> IO ()
broadcast message clients = do
  forM_ clients $ \(n, conn) -> do
   T.putStrLn message
   WS.sendTextData conn message

main :: MVar () -> IO ()
main kill = do
    state <- newMVar newServerState
    race_ (takeMVar kill) (WS.runServer "127.0.0.1" 9160 $ app state)

app :: MVar ServerState -> WS.ServerApp
app state pending = do
    conn <- WS.acceptRequest pending
    WS.withPingThread conn 30 (return ()) $ do
        msg <- WS.receiveData conn
        clients <- readMVar state
        let client = ("NEW CLIENT", conn)
        modifyMVar_ state $ \s -> do
         let clientList = addClient client s
         return clientList
        cli <- readMVar state
        print (map fst cli)
        readMVar state >>= broadcast msg
        flip finally (disconnect client) (talk client state)
  where 
   disconnect client = do
    modifyMVar_ state $ \s -> do
     let s' = removeClient client s
     return (s)

talk :: Client -> MVar ServerState -> IO ()
talk (user, conn) state = forever $ do
    msg <- WS.receiveData conn
    readMVar state >>= broadcast msg 



module Spec where

import           Control.Concurrent  (forkIO, threadDelay, killThread, ThreadId)
import           Control.Concurrent.MVar
import           Control.Concurrent.Chan
import           Control.Monad       (forever, unless)
import           Control.Monad.Trans (liftIO)
import           Network.Socket      (withSocketsDo)
import           Data.Text           (Text)
import qualified Data.Text           as T
import qualified Data.Text.IO        as T
import qualified Network.WebSockets  as WS
import qualified DevelMain
import           DevelMain (Message(..), Greeting(..))
import           Test.Hspec
import           Data.Word
import           Foreign.Store
import           Data.ByteString.Lazy (ByteString(..))
import           Data.Aeson
import           Control.Concurrent.STM.TChan
import           Control.Monad.STM

import qualified MVarController as MVC
import qualified TChanController as TCC

threadStoreIndex :: Word32
threadStoreIndex = 1

main :: IO ()
main = do
  mThreadId <- lookupStore threadStoreIndex :: IO (Maybe (Store ThreadId))
  case (mThreadId) of
   Nothing -> do
    print "No Stored Thread"
    kill <- newEmptyMVar
    tId <- forkIO (DevelMain.main kill)
    _ <- writeStore (Store threadStoreIndex) tId
    threadDelay 1000000
    TCC.clientConnectionTest
    putMVar kill ()
   Just x -> do
    print "Found Thread ID in Store"
    otId <- readStore x
    print (otId)
    killThread otId 
    kill <- newEmptyMVar
    threadDelay 100000
    tId <- forkIO (DevelMain.main kill)
    _ <- writeStore (Store threadStoreIndex) tId
    threadDelay 100000
    TCC.clientConnectionTest
    putMVar kill ()



module MVarController where

import           Control.Concurrent  (forkIO, threadDelay, killThread, ThreadId)
import           Control.Concurrent.MVar
import           Control.Monad       (forever, unless)
import           Control.Monad.Trans (liftIO)
import           Network.Socket      (withSocketsDo)
import qualified Data.Text.IO        as T
import qualified Network.WebSockets  as WS
import           Test.Hspec
import           Data.ByteString.Lazy (ByteString(..))
import           Data.Aeson
import           DevelMain (Message(..), Greeting(..))

type ReadVar a = MVar a
type WriteVar a = MVar a
type Controller a = (WriteVar a, ReadVar a)

wsSlave :: Controller ByteString -> WS.ClientApp ()
wsSlave controller@(wvar, rvar) conn = do
  _ <- forkIO $ writeOut
  loop

  where loop = do 
         val <- tryTakeMVar wvar
         case (val) of
           Just x -> do
             WS.sendTextData conn x
             loop
           _ -> loop

        writeOut = forever $ do
         msg <- WS.receiveData conn
         ise <- isEmptyMVar rvar
         print ise
         case (ise) of
          True -> putMVar rvar msg
          False -> do
           modifyMVar_ rvar $ \m -> do
            return msg

clientConnectionTest :: IO ()
clientConnectionTest = hspec $ do
  let msg = Message "Hello Nice to Meet You all"
  let grt = Greeting "Hello I'm Ethan"
  describe "Test Initial Connection" $ do
    controller <- runIO openController
    runIO $ forkIO $ withSocketsDo $ WS.runClient "127.0.0.1" 9160 "/" $ wsSlave controller
    runIO $ threadDelay 100000
    runIO $ putMVar (fst controller) (encode grt)
    grt1 <- runIO $ takeMVar (snd controller) 
    it "It should allow for a client to connect to the application with a greeting" $ do
      (decode grt1 :: Maybe Greeting) `shouldBe` (Just grt)
    it "It should allow a connected client to send a message" $ do
      putMVar (fst controller) (encode msg)
      msg1 <- readMVar (snd controller) 
      (decode msg1 :: Maybe Message) `shouldBe` (Just msg)

openController :: IO (WriteVar a, ReadVar a)
openController = do
  wVar <- newEmptyMVar
  rVar <- newEmptyMVar
  return (wVar, rVar)

controlLoop :: Controller ByteString -> IO ()
controlLoop controller@(wvar, rvar) = do
  v <- tryTakeMVar wvar :: IO (Maybe ByteString)
  case (v) of
    Just x -> do
      putMVar rvar x
      controlLoop controller
    _ -> controlLoop controller


module TChanController where

import           Control.Concurrent  (forkIO, threadDelay, killThread, ThreadId)
import           Control.Monad       (forever, unless)
import           Network.Socket      (withSocketsDo)
import qualified Data.Text.IO        as T
import qualified Network.WebSockets  as WS
import           DevelMain (Message(..), Greeting(..))
import           Test.Hspec
import           Data.ByteString.Lazy (ByteString(..))
import           Data.Aeson
import           Control.Concurrent.STM.TChan
import           Control.Monad.STM

type ReadChan a = TChan a
type WriteChan a = TChan a
type ControllerChan a = (WriteChan a, ReadChan a)

wsSlave :: ControllerChan ByteString -> WS.ClientApp ()
wsSlave controller@(wchan, rchan) conn = do
  _ <- forkIO $ writeOut
  loop

  where loop = do 
         val <- atomically $ tryReadTChan wchan
         case (val) of
           Just x -> do
             T.putStrLn "HERE"
             WS.sendTextData conn x
             loop
           _ -> loop


        writeOut = forever $ do
         msg <- WS.receiveData conn :: IO ByteString
         print msg

clientConnectionTest :: IO ()
clientConnectionTest = hspec $ do
  let msg = Message "Hello Nice to Meet You all"
  let grt = Greeting "Hello I'm Ethan"
  controller <- runIO openChanController
  -- runIO $ forkIO $ withSocketsDo $ WS.runClient "127.0.0.1" 9160 "/" $ wsSlave controller
  describe "Test Initial Connection" $ do
    -- runIO $ print "ACQUISTION"
    runIO $ threadDelay 100000
    runIO $ forkIO $ controlLoop controller
    -- runIO $ threadDelay 100000
    -- runIO $ print "DELAYED THREAD"
    runIO $ atomically $ writeTChan (fst controller) (encode grt)
    -- runIO $ threadDelay 10000
    -- grt1 <- runIO $ initiateClient controller
    -- runIO $ threadDelay 1000
    runIO $ print "Got To Read"
    grt1 <- runIO $ atomically $ readTChan (snd controller) 
    --let grt1 = encode grt
    --runIO $ print "READ FROM CHANNEL"
    it "It should allow for a client to connect to the application with a greeting" $ do
      (decode grt1 :: Maybe Greeting) `shouldBe` (Just grt)
    {-
    it "It should allow a connected client to send a message" $ do
      atomically $ writeTChan (fst controller) (encode grt)
      msg1 <- atomically $ readTChan (snd controller) 
      (decode msg1 :: Maybe Message) `shouldBe` (Just msg)
    -}

openChanController :: IO (WriteChan a, ReadChan a)
openChanController = do
  wc <- newTChanIO
  rc <- newTChanIO
  return (wc, rc)

controlLoop :: ControllerChan ByteString -> IO ()
controlLoop controller@(wchan, rchan) = do
  v <- atomically $ tryReadTChan wchan :: IO (Maybe ByteString)
  case (v) of
    Just x -> do
      atomically $ writeTChan rchan x
      controlLoop controller
    _ -> controlLoop controller



- async
- aeson
- base >= 4.7 && < 5
- wai
- warp
- http-types
- scotty
- bytestring 
- text
- websockets
- transformers
- mtl
- unordered-containers
- network
- hspec
- foreign-store
- stm