server start hadling pongs

src-server/Server/Communication.hs

@@ -90,13 +90,11 @@ disconnectClients = mapM_
     close clientSocket
   )
 
-timeoutClients
-  :: [(Maybe UUID, Socket)]
+dropClient
+  :: (Maybe UUID, Socket)
   -> IO ()
-timeoutClients = mapM_
-  (\(_, clientSocket) -> do
-    close clientSocket
-  )
+dropClient =
+    close . snd
 
 -- | Process incoming connection requests
 processRequests :: Game ()
@@ -220,11 +218,12 @@ handleMessage stateContainer readerContainer msg = do
           let arena = rcMap readerContainer
           initPos <- rollInitPosition arena
           now <- liftIO getCurrentTime
+          uuid <- nextRandom
           let freshWizard = newWizard initPos
           STM.atomically $ do
             currentPlayers <- STM.readTMVar (scPlayers stateContainer)
             void $ STM.swapTMVar (scPlayers stateContainer) $
-              Player clientId freshWizard False now : currentPlayers
+              Player clientId freshWizard False (now, uuid) : currentPlayers
           let clientSock = fromJust $ lookup (Just clientId) clients
           sendMessage (ProvideInitialWizard freshWizard) clientSock
         ClientReady -> do
@@ -236,6 +235,13 @@ handleMessage stateContainer readerContainer msg = do
             unless (null thisPlayers) $
               void $ STM.swapTMVar (scPlayers stateContainer) $
                 (head thisPlayers) {playerReady = True} : otherPlayers
+        Pong uuid -> do
+          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)
         _          -> pure ()
 
 sendPings :: Game ()
@@ -248,13 +254,13 @@ sendPings = do
   players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
   sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
   mapM_
-    (\(Player playerId (Wizard {}) readiness lastPong) -> do
-      let timeDiff = realToFrac $ diffUTCTime now lastPong
+    (\(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 $ disconnectClients [(Just playerId, clientSock)]
+          liftIO $ dropClient (Just playerId, clientSock)
         else do
           random <- liftIO nextRandom
           liftIO $ sendMessage

src-server/Server/Types.hs

@@ -69,7 +69,7 @@ data Player = Player
   { playerId       :: UUID
   , playerWizard   :: Wizard
   , playerReady    :: Bool
-  , playerLastPong :: UTCTime
+  , playerLastPong :: (UTCTime, UUID)
   }
   deriving (Eq, Show)