diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 3c09b52..10211c8 100644 --- a/src-client/Client/Communication.hs +++ b/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 diff --git a/src-client/Main.hs b/src-client/Main.hs index e852366..3272d0f 100644 --- a/src-client/Main.hs +++ b/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 diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 58a67b1..48adb66 100644 --- a/src-server/Server/Communication.hs +++ b/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