nearing the solution

configuration.yaml

@@ -2,6 +2,6 @@ setSocketPath         : "/tmp/wizard.sock"
 setMapRows            : 40
 setMapColumns         : 40
 setSpawnerProbability : 0.01
-setFPS                : 30
+setFPS                : 1
 setClientMaxTimeout   : 5
 setFramesPerPing      : 120

src-client/Main.hs

@@ -15,7 +15,7 @@ import qualified Data.Matrix as M
 import Graphics.Vty
 import Graphics.Vty.CrossPlatform
 
-import Network.Socket (close)
+import Network.Socket (Socket, close)
 
 import Options.Applicative
 
@@ -44,8 +44,7 @@ main = do
   mockClientState <- STM.newTMVarIO (ClientState undefined False)
   let mockState = StateContainer undefined mockClientState undefined undefined
   sendMessage IdRequest sock
-  receiveMessage sock messageQueue mockState
+  awaitResponse sock messageQueue mockState 0
-  awaitResponse messageQueue 1
   clientIdMsg <- head <$> STM.atomically (STM.flushTQueue messageQueue)
   let clientId = acClientUUID clientIdMsg
   putStrLn $ "received client UUID: " <> show clientId
@@ -57,8 +56,7 @@ main = do
 
   sendMessage (ClientMessage clientId ClientRequestWizard) sock
   -- threadDelay $ 1 * 10 ^ 6
-  receiveMessage sock messageQueue mockState
+  awaitResponse sock messageQueue mockState 1
-  awaitResponse messageQueue 1
   playerWizard <- head <$> STM.atomically (STM.flushTQueue messageQueue)
   putStrLn $ "received wizard: " <> show (initWizard playerWizard)
 
@@ -85,7 +83,7 @@ main = do
   putStrLn "Shutting down client…"
   showCursor (outputIface vty)
   shutdown vty
-  threadDelay (10 ^ 6)
+  threadDelay (10 ^ 3)
   putStrLn "Closing connection to server…"
   close sock
   putStrLn "bye bye"
@@ -112,14 +110,17 @@ welcomeText = mconcat $ map (<> "\n")
   ]
 
 awaitResponse
-  :: STM.TQueue ServerMessage
+  :: Socket
+  -> STM.TQueue ServerMessage
+  -> StateContainer
   -> Int
   -> IO ()
-awaitResponse _ 10 = error "Tries to communicate with server exceeded"
+awaitResponsea _ _ _ 10 = error "Tries to communicate with server exceeded"
-awaitResponse messageQueue numTries = do
+awaitResponse sock messageQueue mockState numTries = do
+  receiveMessage sock messageQueue mockState
   responsePresent <- not <$> STM.atomically (STM.isEmptyTQueue messageQueue)
   if responsePresent
   then pure ()
   else do
     threadDelay $ 10 ^ 6
-    awaitResponse messageQueue (succ numTries)
+    awaitResponse sock messageQueue mockState (succ numTries)

src-server/Main.hs

@@ -54,6 +54,7 @@ main = do
       putStrLn "starting game…"
       now <- getCurrentTime
       sockList <- STM.newTMVarIO []
+      queueList <- STM.newTMVarIO []
       messageQueue <- STM.newTQueueIO
       serverState <- STM.newTMVarIO (ServerState False False)
       emptyPLayers <- STM.newTMVarIO []
@@ -63,7 +64,7 @@ main = do
             setFramesPerPing
             setClientMaxTimeout
             sock
-          initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList messageQueue
+          initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList queueList messageQueue
       (finalState, finalWrite) <- execRWST
         (do
           terminateGameOnSigint

src-server/Server/Communication.hs

@@ -16,6 +16,10 @@ import Control.Monad.IO.Class
 
 import Control.Monad.RWS.Strict
 
+import Data.List (find)
+
+import Data.Maybe (fromJust)
+
 import Network.Socket as Net
 
 import System.Posix.Signals
@@ -51,12 +55,13 @@ terminateGameOnSigint = do
   sock <- asks rcMainSocket
   serverState <- gets scServerState
   clientList <- gets scClientSockets
+  queueList <- gets scClientQueues
   void $ liftIO $ installHandler
     sigINT
     (CatchOnce $ do
       putStrLn "SIGINT caught, terminating…"
-      clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
+      queues <- liftIO $ STM.atomically $ STM.readTMVar queueList
-      disconnectClients clientList clients
+      disconnectClients clientList queues
       threadDelay (10 ^ 6)
       close sock
       st <- STM.atomically $ STM.readTMVar serverState
@@ -68,62 +73,72 @@ terminateGameOnSigint = do
 
 -- | Disconnect all connected clients gracefully by announcing the server quitting
 disconnectClients
-  :: STM.TMVar [ClientComms]
+  :: STM.TMVar [ClientSocket]
-  -> [ClientComms]
+  -> [ClientQueue]
   -> IO ()
-disconnectClients clientList clients = do
+disconnectClients clientSockets queues = do
   putStrLn "server shutting down. Notifying all clients…"
   mapM_
-    (\client -> do
+    (\queue -> do
       maybe
         (pure ())
         (\uuid -> do
           putStrLn $ "notifying client: " <> show uuid
-          queueMessage ServerQuit uuid clientList
+          queueMessage ServerQuit uuid queues
-          dropClient clientList (ccSocket client)
+          sock <- do
+            socketList <- STM.atomically $ STM.readTMVar clientSockets
+            pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList
+          dropClient clientSockets (csSocket sock)
         )
-        (ccUUID client)
+        (cqUUID queue)
     )
-    clients
+    queues
 
 
 -- | Process incoming connection requests
 processRequests :: Game ()
 processRequests = do
   mainSocket <- asks rcMainSocket
-  queue <- gets scMessageQueue
+  serverQueue <- gets scMessageQueue
   socketList <- gets scClientSockets
+  queueList <- gets scClientQueues
   st <- gets scServerState
-  void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
+  void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queueList serverQueue st
   where
-    acceptConnection mainSocket socketList queue st = do
+    acceptConnection mainSocket socketList queueList serverQueue st = do
       putStrLn "Ready for new connection requests…"
       eSock <- try $ accept mainSocket
       case eSock of
         Left (_ :: SomeException) ->
           putStrLn "Main socket vanished!"
         Right (clientSock, _) -> do
-          messageQueue <- STM.newTQueueIO
+          clientQueue <- STM.newTQueueIO
           sockContainer <- STM.newTMVarIO clientSock
-          clientWriteThreadId <- liftIO $ forkIO $ forever $ do
+          receiverThreadId <- liftIO $ forkIO $ forever $ do
-            receiveMessage sockContainer queue socketList
+            receiveMessage sockContainer serverQueue
-          clientListenThreadId <- liftIO $ forkIO $ forever $ do
+          senderThreadId <- liftIO $ forkIO $ forever $ do
-            sendMessageQueue sockContainer messageQueue
+            sendMessageQueue sockContainer clientQueue
           print clientSock
           liftIO $ STM.atomically $ do
-            list <- STM.takeTMVar socketList
+            slist <- STM.takeTMVar socketList
             STM.putTMVar
               socketList
-              (ClientComms
+              (ClientSocket
                 Nothing
                 clientSock
-                messageQueue
+                receiverThreadId
-                clientWriteThreadId
+                senderThreadId
-                clientListenThreadId
+              : slist
-                : list
+              )
+            qlist <- STM.takeTMVar queueList
+            STM.putTMVar queueList
+              (ClientQueue
+                Nothing
+                clientQueue
+              : qlist
               )
           putStrLn "accepted new connection"
           -- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
           -- unless abortCondition $
           --   acceptConnection mainSocket socketList queue st
-          acceptConnection mainSocket socketList queue st
+          acceptConnection mainSocket socketList queueList serverQueue st

src-server/Server/Communication/Handler.hs

@@ -29,19 +29,20 @@ handleMessage
   -> IO ()
 handleMessage stateContainer readerContainer msg = do
   let clientList = scClientSockets stateContainer
+  queueList <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer
   clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
   -- putStrLn $ "Handling: " <> show msg
   case msg of
     IdRequest                      -> do
       clientId <- nextRandom
-      let clientIdx = findIndex (isNothing . ccUUID) clients
+      let clientIdx = findIndex (isNothing . csUUID) clients
-          clientSock = ccSocket $ clients !! fromJust clientIdx
+          clientSock = csSocket $ clients !! fromJust clientIdx
           newClients = map
-            (\old@(ClientComms mUUID oldClientSock _ _ _) ->
+            (\old@(ClientSocket mUUID oldClientSock _ _) ->
               if oldClientSock == clientSock && isNothing mUUID
               then
                 old
-                  { ccUUID = Just clientId
+                  { csUUID = Just clientId
                   }
               else
                 old
@@ -49,13 +50,13 @@ handleMessage stateContainer readerContainer msg = do
             clients
       void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
       putStrLn $ "Accepted Client with UUID " <> show clientId
-      queueMessage (AcceptClient clientId) clientId clientList
+      queueMessage (AcceptClient clientId) clientId queueList
     ClientMessage clientId payload ->
       case payload of
         ClientQuit -> do
           putStrLn $ "client has quit the game: " <> show clientId
-          let client = find (\a -> ccUUID a == Just clientId) clients
+          let client = find (\a -> csUUID a == Just clientId) clients
-          dropClient clientList (ccSocket $ fromJust client)
+          dropClient clientList (csSocket $ fromJust client)
         ClientRequestWizard -> do
           putStrLn "initializing new wizard"
           let arena = rcMap readerContainer
@@ -67,9 +68,8 @@ handleMessage stateContainer readerContainer msg = do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
             void $ STM.swapTMVar (scPlayers stateContainer) $
               Player clientId freshWizard False (now, uuid) : currentPlayers
-          queueMessage (ProvideInitialWizard freshWizard) clientId clientList
+          queueMessage (ProvideInitialWizard freshWizard) clientId queueList
         ClientReady -> do
-          putStrLn $ "client " <> show clientId <> " is ready!"
           now <- getCurrentTime
           STM.atomically $ do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
@@ -82,27 +82,27 @@ handleMessage stateContainer readerContainer msg = do
                   , playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
                   }
                   : otherPlayers
-        Pong uuid -> do
+          putStrLn $ "client ready: " <> show clientId
-          let mclient = find (\c -> ccUUID c == Just clientId) clients
+        Pong pongUuid -> do
+          let mclient = find (\c -> csUUID c == Just clientId) clients
+          players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
           maybe
-            (putStrLn $ "Who is " <> show uuid <> "?")
+            (putStrLn $ "Unknown client: " <> show clientId)
-            (\_ -> do
+            (const $ do
               mPlayer <- STM.atomically $ do
-                players <- STM.readTMVar (scPlayers stateContainer)
                 pure $ find (\p -> playerId p == clientId) players
               maybe
                 (pure ())
                 (\player ->
-                  if snd (playerLastPong player) /= uuid
+                  if snd (playerLastPong player) /= pongUuid
                   then
-                    putStrLn $ "Pong ID mismatch from " <> show clientId
+                    putStrLn $ "Pong ID mismatch from: " <> show clientId
                   else do
                     now <- getCurrentTime
                     STM.atomically$ do
-                      players <- STM.readTMVar (scPlayers stateContainer)
                       let otherPlayers = filter (\a -> playerId a /= playerId player) players
                           modPlayer = player
-                            { playerLastPong = (now, uuid)
+                            { playerLastPong = (now, pongUuid)
                             }
                       void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
                     sendUpdate stateContainer (rcMap readerContainer) player

src-server/Server/Communication/Receive.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Server.Communication.Receive where
 
 import Control.Concurrent (threadDelay)
@@ -30,19 +31,16 @@ import Server.Types
 receiveMessage
   :: STM.TMVar Socket
   -> STM.TQueue ClientMessage
-  -> STM.TMVar [ClientComms]
   -> IO ()
-receiveMessage sockContainer queue clientList = do
+receiveMessage sockContainer queue = do
   randSleep <- randomRIO (1, 1000)
   threadDelay randSleep
-  msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
+  sock <- STM.atomically $ STM.readTMVar sockContainer
   let maxBufferLength = 4096
-  maybe
+  putStrLn "read socket container for receiving"
-    (pure ())
-    (\sock -> do
-      putStrLn "took socket container for receiving"
   mMsg <- do
     ptr <- mallocArray maxBufferLength
+    putStrLn "receiving data"
     eBufferLength <-
       try $ recvBuf sock ptr maxBufferLength
     bufferLength <- case eBufferLength of
@@ -51,12 +49,13 @@ receiveMessage sockContainer queue clientList = do
         -- dropClient clientList sock
         pure 0
       Right len -> pure len
-        msg <- B.pack <$> peekArray bufferLength ptr
-        let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
     free ptr
-        if bufferLength > 0
+    msg <- B.pack <$> peekArray bufferLength ptr
-        then
+    putStrLn $ "received data: " <> show msg
-          pure mJsonMsg
+    if bufferLength > 0 && msg /= ""
+    then do
+      putStrLn $ "received message: " <> show msg
+      pure (A.decode' $ B8.fromStrict msg :: Maybe ClientMessage)
     else
       pure Nothing
   maybe
@@ -67,6 +66,3 @@ receiveMessage sockContainer queue clientList = do
       -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
     )
     mMsg
-      STM.atomically $ STM.putTMVar sockContainer sock
-    )
-    msock

src-server/Server/Communication/Send.hs

@@ -47,33 +47,30 @@ import Server.Types
 queueMessage
   :: ServerMessage
   -> UUID
-  -> STM.TMVar [ClientComms]
+  -> [ClientQueue]
   -> IO ()
-queueMessage msg uuid clientList = do
+queueMessage msg uuid queueList = do
-  clients <- STM.atomically $ STM.readTMVar clientList
+  putStrLn $ "queueing message \"" <> show msg <> "\" for client " <> show uuid <> " …"
-  let mQueue = ccQueue <$> find (\client -> ccUUID client == Just uuid) clients
+  let mQueue = cqQueue <$> find (\client -> cqUUID client == Just uuid) queueList
   maybe
-    (putStrLn $ "unknown client UUID: " <> show uuid)
+    (putStrLn $ "no queue found for client: " <> show uuid)
     (\queue ->
       STM.atomically $ STM.writeTQueue queue msg
       )
     mQueue
+  putStrLn "message queued!"
 
 sendMessageQueue
   :: STM.TMVar Socket
   -> STM.TQueue ServerMessage
   -> IO ()
 sendMessageQueue sockContainer queue = do
-  randSleep <- randomRIO (1, 1000)
-  threadDelay randSleep
-  msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
-  maybe
-    (pure ())
-    (\sock -> do
-      putStrLn "took socket container for sending"
   msgs <- STM.atomically $ STM.flushTQueue queue
   mapM_
     (\msg -> do
+      sock <- STM.atomically $ STM.readTMVar sockContainer
+      putStrLn "read socket container for sending"
+      putStrLn $ "sending message: " <> show msg
       let msgJson = A.encode msg
           msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
       VS.unsafeWith
@@ -88,9 +85,6 @@ sendMessageQueue sockContainer queue = do
         )
     )
     msgs
-      STM.atomically $ STM.putTMVar sockContainer sock
-    )
-    msock
 
 sendPings :: Game ()
 sendPings = do
@@ -100,54 +94,59 @@ sendPings = do
   fps <- asks rcFPS
   stateContainer <- get
   players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
-  sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
+  -- sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
   mapM_
     (\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
       let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
       when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
-        let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
+        -- let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
-        when (isJust clientSock) $
+        -- when (isJust clientSock) $
-          if timeDiff > realToFrac maxTimeout
+          -- if timeDiff > realToFrac maxTimeout
-          then do
+          -- then do
-            liftIO $ do
+          --   liftIO $ do
-              putStrLn $ "dropping client because of timeout: " <> show plId
+          --     putStrLn $ "dropping client because of timeout: " <> show plId
-              dropClient (scClientSockets stateContainer) (fromJust clientSock)
+          --     dropClient (scClientSockets stateContainer) (fromJust clientSock)
-            put stateContainer
+          --   put stateContainer
-          else do
+          -- else do
             random <- liftIO nextRandom
             let newPong = (now, random)
-            liftIO $ queueMessage
+            liftIO $ do
+              queues <- STM.atomically $ STM.readTMVar (scClientQueues stateContainer)
+              queueMessage
                 ( Ping random
                 )
                 plId
-              (scClientSockets stateContainer)
+                queues
             let newPlayer = player
                   { playerLastPong = newPong
                   }
                 otherPlayers = filter (\a -> playerId a /= plId) players
-            liftIO $ void $ STM.atomically $
+            liftIO $ do
+              void $ STM.atomically $
                 STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
+              putStrLn "ping!"
     )
     players
   put stateContainer
 
 -- | Drops the client from internal management and closes its socket, if still present.
 dropClient
-  :: STM.TMVar [ClientComms]
+  :: STM.TMVar [ClientSocket]
   -> Socket
   -> IO ()
 dropClient clientList sock = do
   mClient <- STM.atomically $ do
     clients <- STM.readTMVar clientList
-    let mclient = find (\client -> ccSocket client == sock) clients
+    let mclient = find (\client -> csSocket client == sock) clients
-    let reducedClients = filter (\client -> ccSocket client /= sock) clients
+    let reducedClients = filter (\client -> csSocket client /= sock) clients
     void $ STM.swapTMVar clientList reducedClients
     pure mclient
   maybe
     (putStrLn $ "closing unknown socket: " <> show sock)
     (\client -> do
-      putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ ccUUID client)
+      putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ csUUID client)
-      killThread (ccListener client)
+      killThread (csSender client)
+      killThread (csReceiver client)
     )
     mClient
   close sock
@@ -158,11 +157,11 @@ sendUpdate
   -> Player
   -> IO ()
 sendUpdate stateContainer tileMap player = do
-  slice <- buildSlice player
+  let slice = buildSlice player
   sendSlice slice player
   where
-    buildSlice :: Player -> IO MapSlice
+    buildSlice :: Player -> MapSlice
-    buildSlice (Player _ (Wizard {..}) _ _) = do
+    buildSlice (Player _ (Wizard {..}) _ _) =
       let V2 wr wc = wizardPos
           subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
           leftBound = wizardRot + (pi / 4)
@@ -185,9 +184,12 @@ sendUpdate stateContainer tileMap player = do
                 Nothing
             )
             subCoords
-      pure (MapSlice initViewMatrix [])
+      in
+        MapSlice initViewMatrix []
     sendSlice :: MapSlice -> Player -> IO ()
     sendSlice slice (Player playerId wizard _ _) = do
       let msg = TickUpdate slice wizard
       -- print slice
-      liftIO $ queueMessage msg playerId (scClientSockets stateContainer)
+      liftIO $ do
+        queues <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer
+        queueMessage msg playerId queues

src-server/Server/Game.hs

@@ -36,13 +36,13 @@ runGame = do
       let delta = realToFrac $ diffUTCTime now before
       -- liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> "  \r"
       handleMessages
-      updateSpawners delta
+      -- updateSpawners delta
-      updateWizards delta
+      -- updateWizards delta
-      modify'
+      -- modify'
-        (\s -> s
+      --   (\s -> s
-          { scServerLastTick = now
+      --     { scServerLastTick = now
-          }
+      --     }
-        )
+      --   )
       fps <- asks rcFPS
       sendPings
       let remainingTime = recip (fromIntegral fps) - delta
@@ -50,4 +50,3 @@ runGame = do
         liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
     )
   liftIO $ threadDelay (10 ^ 6)
-  -- liftIO $ killThread recvThread

src-server/Server/Game/Update.hs

@@ -16,7 +16,7 @@ import Server.Types
 
 updateSpawners :: Float -> Game ()
 updateSpawners dt =
-  modify' (\sc@(StateContainer spawners _ _ _ _ _) ->
+  modify' (\sc@(StateContainer spawners _ _ _ _ _ _) ->
     let newSpawners = map
           (\spawner -> do
             let newTTL = spawnerReloadTTL spawner - dt

src-server/Server/Types.hs

@@ -63,16 +63,22 @@ data StateContainer = StateContainer
   , scPlayers        :: STM.TMVar [Player]
   , scServerState    :: STM.TMVar ServerState
   , scServerLastTick :: UTCTime
-  , scClientSockets  :: STM.TMVar [ClientComms]
+  , scClientSockets  :: STM.TMVar [ClientSocket]
+  , scClientQueues   :: STM.TMVar [ClientQueue]
   , scMessageQueue   :: STM.TQueue ClientMessage
   }
 
-data ClientComms = ClientComms
+data ClientSocket = ClientSocket
-  { ccUUID     :: Maybe UUID
+  { csUUID           :: Maybe UUID
-  , ccSocket   :: Socket
+  , csSocket         :: Socket
-  , ccQueue    :: STM.TQueue ServerMessage
+  , csSender         :: ThreadId
-  , ccWriter   :: ThreadId
+  , csReceiver       :: ThreadId
-  , ccListener :: ThreadId
+  }
+  deriving (Eq)
+
+data ClientQueue = ClientQueue
+  { cqUUID           :: Maybe UUID
+  , cqQueue          :: STM.TQueue ServerMessage
   }
   deriving (Eq)