closing in on communication issue

src-client/Client/Communication.hs

@@ -122,20 +122,19 @@ receiveMessage sock queue = do
 terminateGameOnSigint
   :: Game ()
 terminateGameOnSigint = do
-  -- sock <- asks rcSocket
-  -- clientId <- asks rcClientUUID
+  sock <- asks rcSocket
+  clientId <- asks rcClientUUID
   clientState <- gets scClientState
   void $ liftIO $ installHandler
     keyboardSignal
     (CatchOnce $ do
-      currentState <- STM.atomically $ do
+      STM.atomically $ do
         currentState <- STM.readTMVar clientState
         void $ STM.swapTMVar clientState $ currentState { clientStop = True }
-        pure currentState
-      Vty.shutdown (clientVty currentState)
-      -- partingMessage clientId sock
+      -- Vty.shutdown (clientVty currentState)
+      partingMessage clientId sock
       -- Raise SIGINT again so it does not get blocked
-      -- raiseSignal keyboardSignal
+      raiseSignal keyboardSignal
     )
     Nothing
 

src-client/Main.hs

@@ -56,14 +56,14 @@ main = do
   playerWizard <- head <$> STM.atomically (STM.flushTQueue queue)
   putStrLn $ "received wizard: " <> show (initWizard playerWizard)
 
-  cfg <- standardIOConfig
-  vty <- mkVty cfg
+  -- cfg <- standardIOConfig
+  -- vty <- mkVty cfg
   -- hideCursor (outputIface vty)
 
   -- shut down graphical interface for now
-  shutdown vty
+  -- shutdown vty
 
-  clientState <- STM.newTMVarIO (ClientState vty False False)
+  clientState <- STM.newTMVarIO (ClientState undefined False False)
   let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
   let initRead = ReaderContainer sock clientId queue
       initState = StateContainer (initWizard playerWizard) clientState initSlice
@@ -76,7 +76,7 @@ main = do
     )
     initRead
     initState
-  shutdown vty
+  -- shutdown vty
   partingMessage clientId sock
   threadDelay 100
   close sock

src-server/Server/Communication.hs

@@ -97,6 +97,7 @@ dropClient clientList (uuid, clientSocket) = do
     clients <- STM.readTMVar clientList
     let reducedClients = filter ((/= uuid) . fst) clients
     void $ STM.swapTMVar clientList reducedClients
+  putStrLn $ "dropping client " <> show uuid
   close clientSocket
 
 -- | Process incoming connection requests
@@ -147,11 +148,13 @@ handleMessages = do
   queue <- gets scMessageQueue
   serverState <- get
   readerContainer <- ask
-  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
-  void $ liftIO $ do
-    mapM_
-      (handleMessage serverState readerContainer)
-      msgs
+  emptyState <- liftIO $ STM.atomically $ STM.isEmptyTQueue queue
+  unless emptyState $ do
+    msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
+    void $ liftIO $ do
+      mapM_
+        (handleMessage serverState readerContainer)
+        msgs
 
 -- | receive a 'ClientMessage'
 receiveMessage
@@ -243,18 +246,19 @@ handleMessage stateContainer readerContainer msg = do
           player <- STM.atomically $ do
             players <- STM.readTMVar (scPlayers stateContainer)
             pure $ head $ filter (\p -> playerId p == clientId) players
-          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)
+          -- 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)
         _          -> pure ()
 
 sendPings :: Game ()
@@ -267,19 +271,28 @@ sendPings = do
   players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
   sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
   mapM_
-    (\(Player playerId (Wizard {}) readiness (lastPongTime, _)) -> do
+    (\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
       let timeDiff = realToFrac $ diffUTCTime now lastPongTime
       when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
-        let clientSock = lookup (Just playerId) sockets
+        let clientSock = lookup (Just plId) sockets
         when (isJust clientSock) $
           if timeDiff > realToFrac maxTimeout
-          then
-            liftIO $ dropClient (scClientSockets stateContainer) (Just playerId, fromJust clientSock)
+          then do
+            liftIO $ dropClient (scClientSockets stateContainer) (Just plId, fromJust clientSock)
+            put stateContainer
           else do
             random <- liftIO nextRandom
+            let newPong = (lastPongTime, random)
             liftIO $ sendMessage
               ( Ping random
               )
               (fromJust clientSock)
+            let newPlayer = player
+                  { playerLastPong = newPong
+                  }
+                otherPlayers = filter (\a -> playerId a /= plId) players
+            liftIO $ void $ STM.atomically $
+              STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
+            put stateContainer
     )
     players