tidbits
This commit is contained in:
parent
ddbdc0a6e5
commit
73adfff54c
8 changed files with 21 additions and 20 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue