Haskell Code Testing: State Sharing

Question

Haskell Code Testing: State Sharing

I am writing an online game in haskell .. My GameEngine is in statemonad, so it’s easy to check it, and we have properties for it. It is just bliss.

However, the server has a list of users, which is located at MVar. Server.hs There are many threads. One game stream, tcp and websocket streams, each client in its own stream, etc. They all talk to the channels.

The problem is testing some user workflow; as

the user joins and leaves immediately before starting the game.
the user quits the game;
the user completes the game, etc.

The user workflow is associated with all threads in IO(). I tried to write unit tests on functions, skipping channels (pre-populated with values). But they looked very fragile. Every time I change the code, it’s hard to understand why the test failed. This is not very bad, but I am looking for a better way.

How can I check my workflows? Can I use some other programming abstractions?

I am open to all suggestions (FRP / free monads: I do not know any of them .. but if they solve the problem, I am ready to learn.).

Relevant Code:

data Server = Server { serverGameConfig :: Game.GameConfig
                 , serverUsers      :: MVar (M.Map UserID User)
                 , networkChans     :: NetworkChans
                 , serverChan       :: TChan InMessage
                 , clientsChan      :: Chan OutMessage
                 , internalChan     :: Chan ServerSignals
}

runClient :: UserID -> Chan InMessage -> Server -> IO ()
runClient uId clientChan server@Server{..} = do
  let (_, clientSpecificOutChan) = networkChans
  writeChan clientSpecificOutChan $ (uId, ServerMsg "Take a nick name : ")
  msg <- readChan clientChan
  let nick = case msg of
               PlayerName _ name -> Just name
               _ -> Nothing

  case nick of
    Nothing -> runClient uId clientChan server
    Just _ -> do
      let user = User uId nick Waiting
      failedToAdd <- modifyMVar serverUsers $ \users ->
        -- for player we still have name as id ; so keep it unique.
        if isNickTaken users nick
        then return (users, True)
        else return (M.insert uId user users, False)

      if failedToAdd
      then runClient uId clientChan server
      else do atomically $ writeTChan serverChan $ PlayerJoined uId
              writeChan clientSpecificOutChan $ (uId, ServerMsg $ "Hi.. " ++ T.unpack (fromJust nick) ++ ".. Type ready when you are ready to play.. quit to quit.")
              fix $ \loop -> do m <- readChan clientChan
                                case m of
                                 PlayerReady _ -> playClient uId clientChan server
                                 PlayerExit  _ -> atomically $ writeTChan serverChan $ PlayerExit uId
                                 _ -> loop
  where
    isNickTaken users nick = any (\u -> nick == userNick u) users

cleanString :: String -> String
cleanString = reverse . dropWhile (\c -> c == '\n' || c == '\r') . reverse

playClient :: UserID -> Chan InMessage -> Server -> IO ()
playClient clientId inChan Server{..} = do
    -- because every client wants same copy of the message, duplicate channel.
  outClientChan <- dupChan clientsChan
  writeChan outClientChan $ ServerMsg "Waiting for other players to start the game...!!!"

  let (_, clientSpecificOutChan) = networkChans
  writer <- forkIO $ forever $ do
    outMsg <- readChan outClientChan
    writeChan clientSpecificOutChan (clientId, outMsg)

  clientInternalChan <- dupChan internalChan

  -- otherwise gameready msg for this second client joining is lost.
  atomically $ writeTChan serverChan $ PlayerReady clientId

  -- block on ready-signal from server-thread to start the game.
  signal <- readChan clientInternalChan
  case signal of
    GameReadySignal config players -> writeChan outClientChan $ GameReady config players

  writeList2Chan outClientChan [ ServerMsg "Here.. you go!!!"
                               , ServerMsg "Movements: type L for left , R for right, Q for quit... enjoy." ]

  -- todo: for this functionality we would need to use TChan for userChan/inChan
  -- hFlush clientHdl

  fix $ \loop ->
    do
      msg <- readChan inChan
      case msg of
        PlayerExit _ -> void $ writeChan outClientChan $ ServerMsg "Sayonara !!!"
        _ -> atomically (writeTChan serverChan msg) >> loop

  killThread writer

  atomically $ writeTChan serverChan (PlayerExit clientId)