make more sync

src-server/Server/Communication.hs

@@ -19,8 +19,6 @@ import qualified Data.ByteString.Lazy.Char8 as B8
 
 import Data.List
 
-import qualified Data.Matrix as M
-
 import Data.Maybe
 
 import Data.UUID hiding (null)
@@ -32,8 +30,6 @@ import qualified Data.Vector.Storable as VS
 
 import Foreign hiding (void)
 
-import Linear
-
 import Network.Socket as Net
 
 import System.Posix.Signals
@@ -66,13 +62,14 @@ terminateGameOnSigint
   -> Game ()
 terminateGameOnSigint path = do
   sock <- asks rcMainSocket
-  clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
+  clientList <- gets scClientSockets
+  clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
   serverState <- gets scServerState
   void $ liftIO $ installHandler
     sigINT
     (CatchOnce $ do
       putStrLn "SIGINT caught, terminating…"
-      disconnectClients clients
+      disconnectClients clientList clients
       close sock
       removeIfExists path
       void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
@@ -82,19 +79,25 @@ terminateGameOnSigint path = do
     Nothing
 
 disconnectClients
-  :: [(Maybe UUID, Socket)]
+  :: STM.TMVar [(Maybe UUID, Socket)]
+  -> [(Maybe UUID, Socket)]
   -> IO ()
-disconnectClients = mapM_
-  (\(_, clientSocket) -> do
+disconnectClients clientList = mapM_
+  (\client@(_, clientSocket) -> do
     sendMessage ServerQuit clientSocket
-    close clientSocket
+    dropClient clientList client
   )
 
 dropClient
-  :: (Maybe UUID, Socket)
+  :: STM.TMVar [(Maybe UUID, Socket)]
+  -> (Maybe UUID, Socket)
   -> IO ()
-dropClient =
-    close . snd
+dropClient clientList (uuid, clientSocket) = do
+  STM.atomically $ do
+    clients <- STM.readTMVar clientList
+    let reducedClients = filter ((/= uuid) . fst) clients
+    void $ STM.swapTMVar clientList reducedClients
+  close clientSocket
 
 -- | Process incoming connection requests
 processRequests :: Game ()
@@ -236,12 +239,22 @@ handleMessage stateContainer readerContainer msg = do
               void $ STM.swapTMVar (scPlayers stateContainer) $
                 (head thisPlayers) {playerReady = True} : otherPlayers
         Pong uuid -> do
-          let client = fromJust $ (lookup (Just clientId) clients)
+          let client = fromJust (lookup (Just clientId) clients)
           player <- STM.atomically $ do
             players <- STM.readTMVar (scPlayers stateContainer)
             pure $ head $ filter (\p -> playerId p == clientId) players
-          when (snd (playerLastPong player) /= uuid) $
-            dropClient (Just clientId, client)
+          if snd (playerLastPong player) /= uuid
+          then
+            dropClient clientList (Just clientId, client)
+          else do
+            now <- getCurrentTime
+            STM.atomically$ do
+              players <- STM.readTMVar (scPlayers stateContainer)
+              let otherPlayers = filter (/= player) players
+                  modPlayer = player
+                    { playerLastPong = (now, uuid)
+                    }
+              void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
         _          -> pure ()
 
 sendPings :: Game ()
@@ -257,15 +270,16 @@ sendPings = do
     (\(Player playerId (Wizard {}) readiness (lastPongTime, _)) -> do
       let timeDiff = realToFrac $ diffUTCTime now lastPongTime
       when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
-        let clientSock = fromJust (lookup (Just playerId) sockets)
-        if timeDiff > realToFrac maxTimeout
-        then
-          liftIO $ dropClient (Just playerId, clientSock)
-        else do
-          random <- liftIO nextRandom
-          liftIO $ sendMessage
-            ( Ping random
-            )
-            clientSock
+        let clientSock = lookup (Just playerId) sockets
+        when (isJust clientSock) $
+          if timeDiff > realToFrac maxTimeout
+          then
+            liftIO $ dropClient (scClientSockets stateContainer) (Just playerId, fromJust clientSock)
+          else do
+            random <- liftIO nextRandom
+            liftIO $ sendMessage
+              ( Ping random
+              )
+              (fromJust clientSock)
     )
     players