make server non-blocking

configuration.yaml

@@ -2,4 +2,4 @@ setSocketPath         : "/tmp/wizard.sock"
 setMapRows            : 20
 setMapColumns         : 20
 setSpawnerProbability : 0.01
-setFPS                : 1
+setFPS                : 5

src-client/Main.hs

@@ -23,6 +23,9 @@ main = do
   threadDelay $ 5 * 10 ^ 6
   clientId <- receiveMessage sock
   putStrLn $ "received client UUID: " <> show (acClientUUID clientId)
+  threadDelay $ 5 * 10 ^ 6
+  putStrLn "sending quit message"
+  sendMessage (ClientMessage (acClientUUID clientId) ClientQuit) sock
   where
     opts = info (options <**> helper)
       ( fullDesc

src-server/Server/Communication.hs

@@ -20,6 +20,7 @@ import Data.List
 
 import Data.Maybe
 
+import Data.UUID
 import Data.UUID.V4
 
 import qualified Data.Vector.Storable as VS
@@ -75,6 +76,7 @@ terminateGameOnSigint = do
   where
     disconnectClients = mapM_
       (\(_, clientSocket) -> do
+        sendMessage ServerQuit clientSocket
         close clientSocket
       )
 
@@ -111,20 +113,22 @@ processMessages :: Game ()
 processMessages = do
   clientsVar <- gets scClientSockets
   clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
+  queue <- gets scMessageQueue
   mapM_
-    (\(uuid, clientSocket) -> do
-      receiveMessage clientSocket
-      handleMessage
+    (\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do
+      receiveMessage clientSocket queue
+      handleMessage queue clientsVar
     )
     clients
 
 -- | receive a 'ClientMessage'
 receiveMessage
   :: Socket
-  -> Game ()
-receiveMessage sock = do
+  -> STM.TQueue ClientMessage
+  -> IO ()
+receiveMessage sock queue = do
   let maxBufferLength = 4096
-  mmsg <- liftIO $ do
+  mmsg <- do
     ptr <- mallocArray maxBufferLength
     bufferLength <- recvBuf sock ptr maxBufferLength
     msg <- B.pack <$> peekArray bufferLength ptr
@@ -138,25 +142,24 @@ receiveMessage sock = do
   maybe
     (pure ())
     (\msg -> do
-      queue <- gets scMessageQueue
       liftIO $ STM.atomically $ STM.writeTQueue queue msg
     )
     mmsg
 
 -- | function for translating 'ClientMessage's into server actions
 handleMessage
-  :: Game ()
-handleMessage = do
-  queue <- gets scMessageQueue
+  :: STM.TQueue ClientMessage
+  -> STM.TMVar [(Maybe UUID, Socket)]
+  -> IO ()
+handleMessage queue clientList = do
   msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
-  clientList <- gets scClientSockets
   clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
   mapM_
     (\msg -> liftIO $ do
         putStrLn "Handling following:"
         print msg
         case msg of
-          IdRequest -> do
+          IdRequest                      -> do
             clientId <- nextRandom
             let clientIdx = findIndex (\a -> fst a == Nothing) clients
             let clientSock = snd $ clients !! fromJust clientIdx
@@ -172,6 +175,12 @@ handleMessage = do
                   )
                   clients
             void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
-          _ -> pure ()
+          ClientMessage clientId payload ->
+            case payload of
+              ClientQuit -> do
+                putStrLn $ "removing client " <> show clientId
+                let newClients = filter (\a -> fst a /= Just clientId) clients
+                void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
+              _          -> pure ()
     )
     msgs