From a202ec17b35ebcc9b684ea9e115e121fb30ee3dd Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 20 Dec 2023 09:04:50 +0100 Subject: [PATCH] figure out timing problems --- configuration.yaml | 2 +- src-client/Client/Communication.hs | 32 +++++++++++++++++++----------- src-client/Client/Game.hs | 11 ++++++++-- src-client/Main.hs | 9 +++++---- src-server/Server/Communication.hs | 14 +++++++------ src-server/Server/Game.hs | 9 +++++++-- 6 files changed, 50 insertions(+), 27 deletions(-) diff --git a/configuration.yaml b/configuration.yaml index 6414334..658de8a 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 40 setMapColumns : 40 setSpawnerProbability : 0.01 -setFPS : 30 +setFPS : 60 diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 2372f33..5b4fafd 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -11,6 +11,8 @@ import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as B8 +import Data.UUID + import qualified Data.Vector.Storable as VS import Foreign hiding (void) @@ -50,7 +52,6 @@ sendMessage msg sock = do handleMessages :: Game () handleMessages = do - sock <- asks rcSocket queue <- asks rcQueue msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue mapM_ @@ -61,21 +62,21 @@ handleMessage :: ServerMessage -> Game () handleMessage ServerQuit = do - state <- get - let stateCont = scClientState state + st <- get + let stateCont = scClientState st liftIO $ STM.atomically $ do - state <- STM.readTMVar stateCont - void $ STM.swapTMVar stateCont $ state + stateContainer <- STM.readTMVar stateCont + void $ STM.swapTMVar stateCont $ stateContainer { clientStop = True } - put $ state + put $ st { scClientState = stateCont } liftIO $ putStrLn "Quitting due to server shutdown" handleMessage (TickUpdate slice wizard) = do - modify' (\state@(StateContainer {..}) -> - state + modify' (\st@(StateContainer {}) -> + st { scWizard = wizard , scMapSlice = slice } @@ -103,8 +104,8 @@ 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 @@ -114,9 +115,16 @@ terminateGameOnSigint = do void $ STM.swapTMVar clientState $ currentState { clientStop = True } pure currentState Vty.shutdown (clientVty currentState) - sendMessage (ClientMessage clientId ClientQuit) sock - close sock + -- partingMessage clientId sock -- Raise SIGINT again so it does not get blocked -- raiseSignal keyboardSignal ) Nothing + +partingMessage + :: UUID + -> Socket + -> IO () +partingMessage clientId sock = do + sendMessage (ClientMessage clientId ClientQuit) sock + -- close sock diff --git a/src-client/Client/Game.hs b/src-client/Client/Game.hs index 69f64ae..bb892d6 100644 --- a/src-client/Client/Game.hs +++ b/src-client/Client/Game.hs @@ -1,7 +1,11 @@ module Client.Game where +import Control.Concurrent + import qualified Control.Concurrent.STM as STM +import Control.Monad + import Control.Monad.Loops import Control.Monad.RWS @@ -15,9 +19,12 @@ import Library.Types runGame :: Game () runGame = do - handleMessages + sock <- asks rcSocket + queue <- asks rcQueue + recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue whileM_ (not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState)) (do - pure () + handleMessages ) + liftIO $ killThread recvThread diff --git a/src-client/Main.hs b/src-client/Main.hs index 3626a75..925d5e3 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -7,16 +7,14 @@ import qualified Control.Concurrent.STM as STM import Control.Monad -import Control.Monad.IO.Class - -import Control.Monad.Loops - import Control.Monad.RWS import qualified Data.Matrix as M import Graphics.Vty +import Network.Socket (close) + import Options.Applicative -- internal imports @@ -78,6 +76,9 @@ main = do ) initRead initState + partingMessage clientId sock + threadDelay $ 1 * 10 ^ 6 + close sock where opts = info (options <**> helper) ( fullDesc diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 9e071d2..6791e04 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -23,6 +23,7 @@ import qualified Data.Matrix as M import Data.Maybe +import Data.UUID import Data.UUID.V4 import qualified Data.Vector.Storable as VS @@ -114,12 +115,13 @@ sendMessage msg sock = do (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) -- | receive incoming messages from clients -receiveMessages :: Game () -receiveMessages = do - clientsVar <- gets scClientSockets +receiveMessages + :: STM.TMVar [(Maybe UUID, Socket)] + -> STM.TQueue ClientMessage + -> IO () +receiveMessages clientsVar queue = do clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar - queue <- gets scMessageQueue - void $ liftIO $ forkIO $ mapM_ + mapM_ (\(_, clientSocket) -> do receiveMessage clientSocket queue ) @@ -159,7 +161,7 @@ receiveMessage sock queue = do (pure ()) (\msg -> do liftIO $ STM.atomically $ STM.writeTQueue queue msg - when (msg == IdRequest) (threadDelay $ 10 ^ 3) + -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) ) mmsg diff --git a/src-server/Server/Game.hs b/src-server/Server/Game.hs index 7a1dc31..6a6e6d0 100644 --- a/src-server/Server/Game.hs +++ b/src-server/Server/Game.hs @@ -9,6 +9,8 @@ import Control.Monad.RWS.Strict import Control.Monad.Loops +import Control.Concurrent + import qualified Data.ByteString.Char8 as B8 import Data.Time @@ -27,6 +29,9 @@ import Server.Types runGame :: Game () runGame = do processRequests + clientsVar <- gets scClientSockets + queue <- gets scMessageQueue + recvThread <- liftIO $ forkIO $ forever $ receiveMessages clientsVar queue whileM_ (not . serverStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scServerState)) (do @@ -34,7 +39,6 @@ runGame = do now <- liftIO getCurrentTime let delta = realToFrac $ diffUTCTime now before liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> " \r" - receiveMessages handleMessages updateSpawners delta updateWizards delta @@ -44,11 +48,12 @@ runGame = do } ) fps <- asks rcFPS - sendUpdates + -- sendUpdates let remainingTime = recip (fromIntegral fps) - delta when (remainingTime > 0) $ liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6 ) + liftIO $ killThread recvThread updateSpawners :: Float -> Game () updateSpawners dt =