diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 31e545c..6e01d20 100644 --- a/src-client/Client/Communication.hs +++ b/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 diff --git a/src-client/Client/Events.hs b/src-client/Client/Events.hs index 594ed33..110a72f 100644 --- a/src-client/Client/Events.hs +++ b/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 Data.IORef (modifyIORef') +import Control.Monad.RWS (asks, get) import Graphics.Vty -- internal imports +import Client.Communication import Client.Types handleEvent :: Event -> Game () handleEvent (EvKey KEsc _) = do - stopper <- gets scStopper - liftIO $ modifyIORef' stopper (const True) + st <- get + liftIO $ gracefulExit st "Quitting due to user input" handleEvent _ = pure () diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 2d07693..13c408c 100644 --- a/src-server/Server/Communication.hs +++ b/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 diff --git a/src-server/Server/Communication/Handler.hs b/src-server/Server/Communication/Handler.hs index da9b74a..e403ae3 100644 --- a/src-server/Server/Communication/Handler.hs +++ b/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 diff --git a/src-server/Server/Communication/Send.hs b/src-server/Server/Communication/Send.hs index 19afb62..08afd8b 100644 --- a/src-server/Server/Communication/Send.hs +++ b/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