This commit is contained in:
Amedeo Molnár 2024-11-29 11:24:07 +01:00
parent ddbdc0a6e5
commit 73adfff54c
8 changed files with 21 additions and 20 deletions

View file

@ -68,7 +68,7 @@ main = do
sock sock
logLevel logLevel
initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList queueList messageQueue initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList queueList messageQueue
(finalState, finalWrite) <- execRWST (_finalState, _finalWrite) <- execRWST
(do (do
terminateGameOnSigint terminateGameOnSigint
runGame runGame

View file

@ -63,7 +63,7 @@ terminateGameOnSigint = do
(CatchOnce $ do (CatchOnce $ do
logPrintIO curLevel Info "SIGINT caught, terminating…" logPrintIO curLevel Info "SIGINT caught, terminating…"
disconnectClients curLevel clientList queueList disconnectClients curLevel clientList queueList
threadDelay (10 ^ 6) threadDelay (10 ^ (6 :: Int))
close sock close sock
st <- STM.atomically $ STM.readTMVar serverState st <- STM.atomically $ STM.readTMVar serverState
void $ STM.atomically $ STM.swapTMVar serverState $ st void $ STM.atomically $ STM.swapTMVar serverState $ st
@ -121,13 +121,13 @@ processRequests = do
sockContainer <- STM.newTMVarIO clientSock sockContainer <- STM.newTMVarIO clientSock
receiverThreadId <- liftIO $ do receiverThreadId <- liftIO $ do
t <- forkIO $ do t <- forkIO $ do
threadDelay $ 10 ^ 6 threadDelay $ 10 ^ (6 :: Int)
forever $ receiveMessage curLevel socketList queueList sockContainer serverQueue forever $ receiveMessage curLevel socketList queueList sockContainer serverQueue
logPrintIO curLevel Verbose "enabled listener thread" logPrintIO curLevel Verbose "enabled listener thread"
pure t pure t
senderThreadId <- liftIO $ do senderThreadId <- liftIO $ do
t <- forkIO $ do t <- forkIO $ do
threadDelay $ 10 ^ 6 threadDelay $ 10 ^ (6 :: Int)
forever $ sendMessageQueue curLevel sockContainer clientQueue forever $ sendMessageQueue curLevel sockContainer clientQueue
logPrintIO curLevel Verbose "enabled sender thread" logPrintIO curLevel Verbose "enabled sender thread"
pure t pure t

View file

@ -7,8 +7,6 @@ import qualified Control.Concurrent.STM as STM
import Control.Exception import Control.Exception
import Control.Monad.IO.Class
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.ByteString as B import qualified Data.ByteString as B

View file

@ -94,7 +94,7 @@ sendMessageQueue curLevel sockContainer queue = do
sendPings :: Game () sendPings :: Game ()
sendPings = do sendPings = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
maxTimeout <- asks rcClientMaxTimeout _maxTimeout <- asks rcClientMaxTimeout
framesPerPing <- asks rcFramesPerPing framesPerPing <- asks rcFramesPerPing
curLevel <- asks rcLogLevel curLevel <- asks rcLogLevel
fps <- asks rcFPS fps <- asks rcFPS

View file

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Server.Game where module Server.Game where
import Control.Concurrent import Control.Concurrent
@ -47,6 +46,6 @@ runGame = do
sendPings sendPings
let remainingTime = recip (fromIntegral fps) - delta let remainingTime = recip (fromIntegral fps) - delta
when (remainingTime > 0) $ when (remainingTime > 0) $
liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6 liftIO $ threadDelay $ floor (remainingTime * 10 ^ (6 :: Int) :: Float)
) )
liftIO $ threadDelay (10 ^ 6) liftIO $ threadDelay (10 ^ (6 :: Int))

View file

@ -8,6 +8,8 @@ import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Data.List (foldl')
-- internal imports -- internal imports
import Library.Types import Library.Types
@ -40,8 +42,8 @@ updateWizards dt = do
playersVar <- gets scPlayers playersVar <- gets scPlayers
players <- liftIO $ STM.atomically $ STM.readTMVar playersVar players <- liftIO $ STM.atomically $ STM.readTMVar playersVar
let newPlayers = map let newPlayers = map
(\player@(Player pId wizard@(Wizard _ _ health _ _ effects) readiness lastPong) -> (\player@(Player _pId wizard@(Wizard _ _ health _ _ effects) readiness _lastPong) ->
let newEffects = foldl let newEffects = foldl'
(\acc effect@(Effect _ ttl) -> (\acc effect@(Effect _ ttl) ->
if ttl - dt < 0 if ttl - dt < 0
then acc then acc
@ -51,7 +53,7 @@ updateWizards dt = do
) )
[] []
effects effects
effectDamage = foldl effectDamage = foldl'
(\acc (Effect kind _) -> (\acc (Effect kind _) ->
if kind `elem` harmingAfflictions if kind `elem` harmingAfflictions
then acc + 1 then acc + 1

View file

@ -71,13 +71,13 @@ data ReaderContainer = ReaderContainer
deriving (Eq, Show) deriving (Eq, Show)
data StateContainer = StateContainer data StateContainer = StateContainer
{ scSpawners :: [Spawner] { scSpawners :: ![Spawner]
, scPlayers :: STM.TMVar [Player] , scPlayers :: !(STM.TMVar [Player])
, scServerState :: STM.TMVar ServerState , scServerState :: !(STM.TMVar ServerState)
, scServerLastTick :: UTCTime , scServerLastTick :: !UTCTime
, scClientSockets :: STM.TMVar [ClientSocket] , scClientSockets :: !(STM.TMVar [ClientSocket])
, scClientQueues :: STM.TMVar [ClientQueue] , scClientQueues :: !(STM.TMVar [ClientQueue])
, scMessageQueue :: STM.TQueue ClientMessage , scMessageQueue :: !(STM.TQueue ClientMessage)
} }
data ClientSocket = ClientSocket data ClientSocket = ClientSocket

View file

@ -75,6 +75,8 @@ executable wizard-wipeout-server
Server.Map Server.Map
Server.Types Server.Types
Server.Util Server.Util
default-extensions:
StrictData
-- other-extensions: -- other-extensions:
build-depends: base >=4.17.2.1 build-depends: base >=4.17.2.1
, aeson , aeson