fix pingpong procedure

configuration.yaml

@@ -4,4 +4,4 @@ setMapColumns         : 40
 setSpawnerProbability : 0.01
 setFPS                : 60
 setClientMaxTimeout   : 5
-setFramesPerPing      : 30
+setFramesPerPing      : 120

src-server/Server/Communication.hs

@@ -71,7 +71,10 @@ terminateGameOnSigint = do
       putStrLn "SIGINT caught, terminating…"
       disconnectClients clientList clients
       close sock
-      void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
+      st <- STM.atomically $ STM.readTMVar serverState
+      void $ STM.atomically $ STM.swapTMVar serverState $ st
+        { serverStop = True
+        }
     )
     Nothing
 
@@ -118,17 +121,26 @@ processRequests = do
   mainSocket <- asks rcMainSocket
   queue <- gets scMessageQueue
   socketList <- gets scClientSockets
-  void $ liftIO $ forkIO $ forever $ acceptConnection mainSocket socketList queue
+  st <- gets scServerState
+  void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
   where
-    acceptConnection mainSocket socketList queue = do
+    acceptConnection mainSocket socketList queue st = do
       putStrLn "Ready for new connection requests…"
-      (clientSock, _) <- accept mainSocket
+      esock <- try $ accept mainSocket
-      clientThreadId <- liftIO $ forkIO $ forever $ do
+      case esock of
-        receiveMessage clientSock queue socketList
+        Left (_ :: SomeException) ->
-      liftIO $ STM.atomically $ do
+          putStrLn "Main socket vanished!"
-        list <- STM.takeTMVar socketList
+        Right (clientSock, _) -> do
-        STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
+          clientThreadId <- liftIO $ forkIO $ forever $ do
-      putStrLn "accepted new connection"
+            receiveMessage clientSock queue socketList
+          liftIO $ STM.atomically $ do
+            list <- STM.takeTMVar socketList
+            STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
+          putStrLn "accepted new connection"
+          abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
+          unless abortCondition $
+            acceptConnection mainSocket socketList queue st
+
 
 -- | Sends a specified message through given socket to the client
 sendMessage
@@ -267,23 +279,33 @@ handleMessage stateContainer readerContainer msg = do
               void $ STM.swapTMVar (scPlayers stateContainer) $
                 (head thisPlayers) {playerReady = True} : otherPlayers
         Pong uuid -> do
-          -- let client = fromJust (find (\c -> ccUUID c == Just clientId) clients)
+          let mclient = find (\c -> ccUUID c == Just clientId) clients
-          player <- STM.atomically $ do
+          maybe
-            players <- STM.readTMVar (scPlayers stateContainer)
+            (putStrLn $ "Who is " <> show uuid <> "?")
-            pure $ head $ filter (\p -> playerId p == clientId) players
+            (\client -> do
-          -- if snd (playerLastPong player) /= uuid
+              mplayer <- STM.atomically $ do
-          -- then do
+                players <- STM.readTMVar (scPlayers stateContainer)
-          --   putStrLn $ "dropping client " <> show clientId
+                pure $ find (\p -> playerId p == clientId) players
-          --   dropClient clientList (Just clientId, client)
+              maybe
-          -- else do
+                (pure ())
-          now <- getCurrentTime
+                (\player ->
-          STM.atomically$ do
+                  if snd (playerLastPong player) /= uuid
-            players <- STM.readTMVar (scPlayers stateContainer)
+                  then do
-            let otherPlayers = filter (\a -> playerId a /= playerId player) players
+                    putStrLn $ "dropping client " <> show clientId
-                modPlayer = player
+                    dropClient clientList (ccSocket client)
-                  { playerLastPong = (now, uuid)
+                  else do
-                  }
+                    now <- getCurrentTime
-            void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
+                    STM.atomically$ do
+                      players <- STM.readTMVar (scPlayers stateContainer)
+                      let otherPlayers = filter (\a -> playerId a /= playerId player) players
+                          modPlayer = player
+                            { playerLastPong = (now, uuid)
+                            }
+                      void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
+                )
+                mplayer
+            )
+            mclient
 
 sendPings :: Game ()
 sendPings = do
@@ -306,7 +328,7 @@ sendPings = do
             put stateContainer
           else do
             random <- liftIO nextRandom
-            let newPong = (lastPongTime, random)
+            let newPong = (now, random)
             liftIO $ sendMessage
               ( Ping random
               )