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
-      clientThreadId <- liftIO $ forkIO $ forever $ do
-        receiveMessage clientSock queue socketList
-      liftIO $ STM.atomically $ do
-        list <- STM.takeTMVar socketList
-        STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
-      putStrLn "accepted new connection"
+      esock <- try $ accept mainSocket
+      case esock of
+        Left (_ :: SomeException) ->
+          putStrLn "Main socket vanished!"
+        Right (clientSock, _) -> do
+          clientThreadId <- liftIO $ forkIO $ forever $ do
+            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)
-          player <- STM.atomically $ do
-            players <- STM.readTMVar (scPlayers stateContainer)
-            pure $ head $ filter (\p -> playerId p == clientId) players
-          -- if snd (playerLastPong player) /= uuid
-          -- then do
-          --   putStrLn $ "dropping client " <> show clientId
-          --   dropClient clientList (Just clientId, client)
-          -- else do
-          now <- getCurrentTime
-          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)
+          let mclient = find (\c -> ccUUID c == Just clientId) clients
+          maybe
+            (putStrLn $ "Who is " <> show uuid <> "?")
+            (\client -> do
+              mplayer <- STM.atomically $ do
+                players <- STM.readTMVar (scPlayers stateContainer)
+                pure $ find (\p -> playerId p == clientId) players
+              maybe
+                (pure ())
+                (\player ->
+                  if snd (playerLastPong player) /= uuid
+                  then do
+                    putStrLn $ "dropping client " <> show clientId
+                    dropClient clientList (ccSocket client)
+                  else do
+                    now <- getCurrentTime
+                    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
               )