From 6587f97312246c440b128f26f7e5c5bf5c82aa24 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 2 Feb 2024 08:16:28 +0100 Subject: [PATCH] begin synchronisation primitives --- src-server/Server/Communication.hs | 79 ++++++++++++------------------ src-server/Server/Types.hs | 17 ++++--- 2 files changed, 43 insertions(+), 53 deletions(-) diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index f01c41d..633517a 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -26,6 +26,8 @@ import Data.Maybe import Data.UUID hiding (null) import Data.UUID.V4 +import Data.Time + import qualified Data.Vector.Storable as VS import Foreign hiding (void) @@ -78,12 +80,15 @@ terminateGameOnSigint path = do -- raiseSignal sigINT ) Nothing - where - disconnectClients = mapM_ - (\(_, clientSocket) -> do - sendMessage ServerQuit clientSocket - close clientSocket - ) + +disconnectClients + :: [Client] + -> IO () +disconnectClients = mapM_ + (\(_, clientSocket) -> do + sendMessage ServerQuit clientSocket + close clientSocket + ) -- | Process incoming connection requests processRequests :: Game () @@ -178,11 +183,11 @@ handleMessage stateContainer readerContainer msg = do case msg of IdRequest -> do clientId <- nextRandom - let clientIdx = findIndex (\a -> fst a == Nothing) clients + let clientIdx = findIndex (isNothing . fst) clients let clientSock = snd $ clients !! fromJust clientIdx let newClients = map (\old@(muuid, oldClientSock) -> - if oldClientSock == clientSock && muuid == Nothing + if oldClientSock == clientSock && isNothing muuid then (Just clientId, clientSock) else @@ -224,49 +229,29 @@ handleMessage stateContainer readerContainer msg = do (head thisPlayers) {playerReady = True} : otherPlayers _ -> pure () -sendUpdates :: Game () -sendUpdates = do +sendPings :: Game () +sendPings = do + now <- liftIO getCurrentTime tileMap <- asks rcMap + maxTimeout <- asks rcClientMaxTimeout + framesPerPing <- asks rcFramesPerPing + fps <- asks rcFPS stateContainer <- get players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer) mapM_ - (\(Player playerId wizard@(Wizard {..}) readiness) -> do - when readiness $ do - let V2 wr wc = wizardPos - subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4] - leftBound = wizardRot + (pi / 4) - rightBound = wizardRot - (pi / 4) - leftLine row = cos leftBound * row - rightLine row = sin rightBound * row - correctionLeft = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2 - then floor - else ceiling - correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2 - then ceiling - else floor - viewMatrix = M.fromList 9 9 $ map - (\(qr, qc) -> - if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr)) - && qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr)) - then - M.safeGet qr qc tileMap - else - Nothing - ) - subCoords - clientSock = fromJust $ lookup (Just playerId) sockets - -- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords - -- liftIO $ print initViewMatrix - liftIO $ sendMessage - (TickUpdate - { tuWizard = wizard - , tuMapSlice = MapSlice - { msViewMap = viewMatrix - , msContents = [] - } - } - ) - clientSock + (\(Player playerId (Wizard {}) readiness lastPong) -> do + let timeDiff = realToFrac $ diffUTCTime now lastPong + when (readiness && timeDiff > (framesPerPing * recip fps)) $ do + let clientSock = fromJust (lookup (Just playerId) sockets) + if timeDiff > maxTimeout + then + liftIO $ disconnectClients [clientSock] + else do + random <- liftIO $ nextRandom + liftIO $ sendMessage + ( Ping random + ) + clientSock ) players diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 11ebfc9..97789c4 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -27,6 +27,8 @@ data Settings = Settings , setMapColumns :: Int , setSpawnerProbability :: Float , setFPS :: Int + , setClientMaxTimeout :: Float + , setFramesPerPing :: Int } deriving (Show, Generic) @@ -46,9 +48,11 @@ options = Options ) data ReaderContainer = ReaderContainer - { rcMap :: ServerMap - , rcFPS :: Int - , rcMainSocket :: Socket + { rcMap :: ServerMap + , rcFPS :: Int + , rcFramesPerPing :: Int + , rcClientMaxTimeout :: Float + , rcMainSocket :: Socket } deriving (Eq, Show) @@ -62,9 +66,10 @@ data StateContainer = StateContainer } data Player = Player - { playerId :: UUID - , playerWizard :: Wizard - , playerReady :: Bool + { playerId :: UUID + , playerWizard :: Wizard + , playerReady :: Bool + , playerLastPong :: UTCTime } deriving (Eq, Show)