further tinkering with communication

src-client/Client/Communication.hs

@@ -70,7 +70,9 @@ handleMessage
   -> Game ()
 handleMessage ServerQuit = do
   st <- get
-  liftIO (gracefulExit st "Quitting due to server shutdown")
+  liftIO $ do
+    putStrLn "Quitting due to server shutdown"
+    writeIORef (scStopper st) True
 
 handleMessage (Ping id') = do
   cid <- asks rcClientUUID

src-client/Client/Events.hs

@@ -4,22 +4,21 @@ import Control.Concurrent.STM (atomically, writeTQueue, flushTQueue)
 
 import Control.Monad.IO.Class (liftIO)
 
-import Control.Monad.RWS (asks, gets)
+import Control.Monad.RWS (asks, get)
-
-import Data.IORef (modifyIORef')
 
 import Graphics.Vty
 
 -- internal imports
 
+import Client.Communication
 import Client.Types
 
 handleEvent
   :: Event
   -> Game ()
 handleEvent (EvKey KEsc _) = do
-  stopper <- gets scStopper
+  st <- get
-  liftIO $ modifyIORef' stopper (const True)
+  liftIO $ gracefulExit st "Quitting due to user input"
 handleEvent _ =
   pure ()
 

src-server/Server/Communication.hs

@@ -85,10 +85,11 @@ disconnectClients clientSockets queueList = do
         (\uuid -> do
           putStrLn $ "notifying client: " <> show uuid
           queueMessage ServerQuit uuid queueList
+          threadDelay 1000 -- wait for the message to be actually sent
           sock <- do
             socketList <- STM.atomically $ STM.readTMVar clientSockets
             pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList
-          dropClient clientSockets (csSocket sock)
+          dropClient clientSockets queueList (csSocket sock)
         )
         (cqUUID queue)
     )
@@ -116,11 +117,11 @@ processRequests = do
           sockContainer <- STM.newTMVarIO clientSock
           receiverThreadId <- liftIO $ do
             t <- forkIO $ forever $ receiveMessage sockContainer serverQueue
-            putStrLn "enabled listener thread"
+            -- putStrLn "enabled listener thread"
             pure t
           senderThreadId <- liftIO $ do
             t <- forkIO $ forever $ sendMessageQueue sockContainer clientQueue
-            putStrLn "enabled sender thread"
+            -- putStrLn "enabled sender thread"
             pure t
           print clientSock
           liftIO $ STM.atomically $ do

src-server/Server/Communication/Handler.hs

@@ -1,5 +1,7 @@
 module Server.Communication.Handler where
 
+import Control.Concurrent (threadDelay)
+
 import qualified Control.Concurrent.STM as STM
 
 import Control.Monad
@@ -36,6 +38,7 @@ handleMessage stateContainer readerContainer msg = do
   case msg of
     IdRequest                      -> do
       clientId <- nextRandom
+      threadDelay 1000
       let clientIdx = findIndex (isNothing . csUUID) socks
           sock = socks !! fromJust clientIdx
           queue = queues !! fromJust clientIdx
@@ -55,13 +58,13 @@ handleMessage stateContainer readerContainer msg = do
         putStrLn $ "Accepted Client with UUID: " <> show clientId
         queueMessage (AcceptClient clientId) clientId queueList
       else
-        putStrLn $ "Unable to assign ID to Socket and queue: " <> show clientId
+        putStrLn $ "Unable to assign ID to socket and queue: " <> show clientId
     ClientMessage clientId payload ->
       case payload of
         ClientQuit -> do
           putStrLn $ "client has quit the game: " <> show clientId
           let client = find (\a -> csUUID a == Just clientId) socks
-          dropClient socketList (csSocket $ fromJust client)
+          dropClient socketList queueList (csSocket $ fromJust client)
         ClientRequestWizard -> do
           putStrLn "initializing new wizard"
           let arena = rcMap readerContainer

src-server/Server/Communication/Send.hs

@@ -136,23 +136,29 @@ sendPings = do
 -- | Drops the client from internal management and closes its socket, if still present.
 dropClient
   :: STM.TMVar [ClientSocket]
+  -> STM.TMVar [ClientQueue]
   -> Socket
   -> IO ()
-dropClient clientList sock = do
+dropClient socketList queueList sock = do
+  clients <- STM.atomically $ STM.readTMVar socketList
   mClient <- STM.atomically $ do
-    clients <- STM.readTMVar clientList
     let mclient = find (\client -> csSocket 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 $ csUUID client)
+      putStrLn $ "killing client sender and listener because of socket closing: " <> show (fromJust $ csUUID client)
       killThread (csSender client)
       killThread (csReceiver client)
     )
     mClient
+  putStrLn $ "dropping client because of socket closing: " <> show (fromJust $ csUUID $ fromJust mClient)
+  STM.atomically $ do
+    queues <- STM.readTMVar queueList
+    let reducedClients = filter (\client -> csSocket client /= sock) clients
+        reducedQueues = filter (\queue -> cqUUID queue /= csUUID (fromJust mClient)) queues
+    void $ STM.swapTMVar socketList reducedClients
+    void $ STM.swapTMVar queueList reducedQueues
   close sock
 
 sendUpdate