nearing the solution
This commit is contained in:
parent
473d9dea6e
commit
e8bdc8a1f7
10 changed files with 181 additions and 161 deletions
|
|
@ -2,6 +2,6 @@ setSocketPath : "/tmp/wizard.sock"
|
|||
setMapRows : 40
|
||||
setMapColumns : 40
|
||||
setSpawnerProbability : 0.01
|
||||
setFPS : 30
|
||||
setFPS : 1
|
||||
setClientMaxTimeout : 5
|
||||
setFramesPerPing : 120
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import qualified Data.Matrix as M
|
|||
import Graphics.Vty
|
||||
import Graphics.Vty.CrossPlatform
|
||||
|
||||
import Network.Socket (close)
|
||||
import Network.Socket (Socket, close)
|
||||
|
||||
import Options.Applicative
|
||||
|
||||
|
|
@ -44,8 +44,7 @@ main = do
|
|||
mockClientState <- STM.newTMVarIO (ClientState undefined False)
|
||||
let mockState = StateContainer undefined mockClientState undefined undefined
|
||||
sendMessage IdRequest sock
|
||||
receiveMessage sock messageQueue mockState
|
||||
awaitResponse messageQueue 1
|
||||
awaitResponse sock messageQueue mockState 0
|
||||
clientIdMsg <- head <$> STM.atomically (STM.flushTQueue messageQueue)
|
||||
let clientId = acClientUUID clientIdMsg
|
||||
putStrLn $ "received client UUID: " <> show clientId
|
||||
|
|
@ -57,8 +56,7 @@ main = do
|
|||
|
||||
sendMessage (ClientMessage clientId ClientRequestWizard) sock
|
||||
-- threadDelay $ 1 * 10 ^ 6
|
||||
receiveMessage sock messageQueue mockState
|
||||
awaitResponse messageQueue 1
|
||||
awaitResponse sock messageQueue mockState 1
|
||||
playerWizard <- head <$> STM.atomically (STM.flushTQueue messageQueue)
|
||||
putStrLn $ "received wizard: " <> show (initWizard playerWizard)
|
||||
|
||||
|
|
@ -85,7 +83,7 @@ main = do
|
|||
putStrLn "Shutting down client…"
|
||||
showCursor (outputIface vty)
|
||||
shutdown vty
|
||||
threadDelay (10 ^ 6)
|
||||
threadDelay (10 ^ 3)
|
||||
putStrLn "Closing connection to server…"
|
||||
close sock
|
||||
putStrLn "bye bye"
|
||||
|
|
@ -112,14 +110,17 @@ welcomeText = mconcat $ map (<> "\n")
|
|||
]
|
||||
|
||||
awaitResponse
|
||||
:: STM.TQueue ServerMessage
|
||||
:: Socket
|
||||
-> STM.TQueue ServerMessage
|
||||
-> StateContainer
|
||||
-> Int
|
||||
-> IO ()
|
||||
awaitResponse _ 10 = error "Tries to communicate with server exceeded"
|
||||
awaitResponse messageQueue numTries = do
|
||||
awaitResponsea _ _ _ 10 = error "Tries to communicate with server exceeded"
|
||||
awaitResponse sock messageQueue mockState numTries = do
|
||||
receiveMessage sock messageQueue mockState
|
||||
responsePresent <- not <$> STM.atomically (STM.isEmptyTQueue messageQueue)
|
||||
if responsePresent
|
||||
then pure ()
|
||||
else do
|
||||
threadDelay $ 10 ^ 6
|
||||
awaitResponse messageQueue (succ numTries)
|
||||
awaitResponse sock messageQueue mockState (succ numTries)
|
||||
|
|
|
|||
|
|
@ -54,6 +54,7 @@ main = do
|
|||
putStrLn "starting game…"
|
||||
now <- getCurrentTime
|
||||
sockList <- STM.newTMVarIO []
|
||||
queueList <- STM.newTMVarIO []
|
||||
messageQueue <- STM.newTQueueIO
|
||||
serverState <- STM.newTMVarIO (ServerState False False)
|
||||
emptyPLayers <- STM.newTMVarIO []
|
||||
|
|
@ -63,7 +64,7 @@ main = do
|
|||
setFramesPerPing
|
||||
setClientMaxTimeout
|
||||
sock
|
||||
initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList messageQueue
|
||||
initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList queueList messageQueue
|
||||
(finalState, finalWrite) <- execRWST
|
||||
(do
|
||||
terminateGameOnSigint
|
||||
|
|
|
|||
|
|
@ -16,6 +16,10 @@ import Control.Monad.IO.Class
|
|||
|
||||
import Control.Monad.RWS.Strict
|
||||
|
||||
import Data.List (find)
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import Network.Socket as Net
|
||||
|
||||
import System.Posix.Signals
|
||||
|
|
@ -51,12 +55,13 @@ terminateGameOnSigint = do
|
|||
sock <- asks rcMainSocket
|
||||
serverState <- gets scServerState
|
||||
clientList <- gets scClientSockets
|
||||
queueList <- gets scClientQueues
|
||||
void $ liftIO $ installHandler
|
||||
sigINT
|
||||
(CatchOnce $ do
|
||||
putStrLn "SIGINT caught, terminating…"
|
||||
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
|
||||
disconnectClients clientList clients
|
||||
queues <- liftIO $ STM.atomically $ STM.readTMVar queueList
|
||||
disconnectClients clientList queues
|
||||
threadDelay (10 ^ 6)
|
||||
close sock
|
||||
st <- STM.atomically $ STM.readTMVar serverState
|
||||
|
|
@ -68,62 +73,72 @@ terminateGameOnSigint = do
|
|||
|
||||
-- | Disconnect all connected clients gracefully by announcing the server quitting
|
||||
disconnectClients
|
||||
:: STM.TMVar [ClientComms]
|
||||
-> [ClientComms]
|
||||
:: STM.TMVar [ClientSocket]
|
||||
-> [ClientQueue]
|
||||
-> IO ()
|
||||
disconnectClients clientList clients = do
|
||||
disconnectClients clientSockets queues = do
|
||||
putStrLn "server shutting down. Notifying all clients…"
|
||||
mapM_
|
||||
(\client -> do
|
||||
(\queue -> do
|
||||
maybe
|
||||
(pure ())
|
||||
(\uuid -> do
|
||||
putStrLn $ "notifying client: " <> show uuid
|
||||
queueMessage ServerQuit uuid clientList
|
||||
dropClient clientList (ccSocket client)
|
||||
queueMessage ServerQuit uuid queues
|
||||
sock <- do
|
||||
socketList <- STM.atomically $ STM.readTMVar clientSockets
|
||||
pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList
|
||||
dropClient clientSockets (csSocket sock)
|
||||
)
|
||||
(ccUUID client)
|
||||
(cqUUID queue)
|
||||
)
|
||||
clients
|
||||
queues
|
||||
|
||||
|
||||
-- | Process incoming connection requests
|
||||
processRequests :: Game ()
|
||||
processRequests = do
|
||||
mainSocket <- asks rcMainSocket
|
||||
queue <- gets scMessageQueue
|
||||
serverQueue <- gets scMessageQueue
|
||||
socketList <- gets scClientSockets
|
||||
queueList <- gets scClientQueues
|
||||
st <- gets scServerState
|
||||
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
|
||||
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queueList serverQueue st
|
||||
where
|
||||
acceptConnection mainSocket socketList queue st = do
|
||||
acceptConnection mainSocket socketList queueList serverQueue st = do
|
||||
putStrLn "Ready for new connection requests…"
|
||||
eSock <- try $ accept mainSocket
|
||||
case eSock of
|
||||
Left (_ :: SomeException) ->
|
||||
putStrLn "Main socket vanished!"
|
||||
Right (clientSock, _) -> do
|
||||
messageQueue <- STM.newTQueueIO
|
||||
clientQueue <- STM.newTQueueIO
|
||||
sockContainer <- STM.newTMVarIO clientSock
|
||||
clientWriteThreadId <- liftIO $ forkIO $ forever $ do
|
||||
receiveMessage sockContainer queue socketList
|
||||
clientListenThreadId <- liftIO $ forkIO $ forever $ do
|
||||
sendMessageQueue sockContainer messageQueue
|
||||
receiverThreadId <- liftIO $ forkIO $ forever $ do
|
||||
receiveMessage sockContainer serverQueue
|
||||
senderThreadId <- liftIO $ forkIO $ forever $ do
|
||||
sendMessageQueue sockContainer clientQueue
|
||||
print clientSock
|
||||
liftIO $ STM.atomically $ do
|
||||
list <- STM.takeTMVar socketList
|
||||
slist <- STM.takeTMVar socketList
|
||||
STM.putTMVar
|
||||
socketList
|
||||
(ClientComms
|
||||
(ClientSocket
|
||||
Nothing
|
||||
clientSock
|
||||
messageQueue
|
||||
clientWriteThreadId
|
||||
clientListenThreadId
|
||||
: list
|
||||
receiverThreadId
|
||||
senderThreadId
|
||||
: slist
|
||||
)
|
||||
qlist <- STM.takeTMVar queueList
|
||||
STM.putTMVar queueList
|
||||
(ClientQueue
|
||||
Nothing
|
||||
clientQueue
|
||||
: qlist
|
||||
)
|
||||
putStrLn "accepted new connection"
|
||||
-- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
|
||||
-- unless abortCondition $
|
||||
-- acceptConnection mainSocket socketList queue st
|
||||
acceptConnection mainSocket socketList queue st
|
||||
acceptConnection mainSocket socketList queueList serverQueue st
|
||||
|
|
|
|||
|
|
@ -29,19 +29,20 @@ handleMessage
|
|||
-> IO ()
|
||||
handleMessage stateContainer readerContainer msg = do
|
||||
let clientList = scClientSockets stateContainer
|
||||
queueList <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer
|
||||
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
|
||||
-- putStrLn $ "Handling: " <> show msg
|
||||
case msg of
|
||||
IdRequest -> do
|
||||
clientId <- nextRandom
|
||||
let clientIdx = findIndex (isNothing . ccUUID) clients
|
||||
clientSock = ccSocket $ clients !! fromJust clientIdx
|
||||
let clientIdx = findIndex (isNothing . csUUID) clients
|
||||
clientSock = csSocket $ clients !! fromJust clientIdx
|
||||
newClients = map
|
||||
(\old@(ClientComms mUUID oldClientSock _ _ _) ->
|
||||
(\old@(ClientSocket mUUID oldClientSock _ _) ->
|
||||
if oldClientSock == clientSock && isNothing mUUID
|
||||
then
|
||||
old
|
||||
{ ccUUID = Just clientId
|
||||
{ csUUID = Just clientId
|
||||
}
|
||||
else
|
||||
old
|
||||
|
|
@ -49,13 +50,13 @@ handleMessage stateContainer readerContainer msg = do
|
|||
clients
|
||||
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
|
||||
putStrLn $ "Accepted Client with UUID " <> show clientId
|
||||
queueMessage (AcceptClient clientId) clientId clientList
|
||||
queueMessage (AcceptClient clientId) clientId queueList
|
||||
ClientMessage clientId payload ->
|
||||
case payload of
|
||||
ClientQuit -> do
|
||||
putStrLn $ "client has quit the game: " <> show clientId
|
||||
let client = find (\a -> ccUUID a == Just clientId) clients
|
||||
dropClient clientList (ccSocket $ fromJust client)
|
||||
let client = find (\a -> csUUID a == Just clientId) clients
|
||||
dropClient clientList (csSocket $ fromJust client)
|
||||
ClientRequestWizard -> do
|
||||
putStrLn "initializing new wizard"
|
||||
let arena = rcMap readerContainer
|
||||
|
|
@ -67,9 +68,8 @@ handleMessage stateContainer readerContainer msg = do
|
|||
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
|
||||
void $ STM.swapTMVar (scPlayers stateContainer) $
|
||||
Player clientId freshWizard False (now, uuid) : currentPlayers
|
||||
queueMessage (ProvideInitialWizard freshWizard) clientId clientList
|
||||
queueMessage (ProvideInitialWizard freshWizard) clientId queueList
|
||||
ClientReady -> do
|
||||
putStrLn $ "client " <> show clientId <> " is ready!"
|
||||
now <- getCurrentTime
|
||||
STM.atomically $ do
|
||||
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
|
||||
|
|
@ -82,27 +82,27 @@ handleMessage stateContainer readerContainer msg = do
|
|||
, playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
|
||||
}
|
||||
: otherPlayers
|
||||
Pong uuid -> do
|
||||
let mclient = find (\c -> ccUUID c == Just clientId) clients
|
||||
putStrLn $ "client ready: " <> show clientId
|
||||
Pong pongUuid -> do
|
||||
let mclient = find (\c -> csUUID c == Just clientId) clients
|
||||
players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer)
|
||||
maybe
|
||||
(putStrLn $ "Who is " <> show uuid <> "?")
|
||||
(\_ -> do
|
||||
(putStrLn $ "Unknown client: " <> show clientId)
|
||||
(const $ do
|
||||
mPlayer <- STM.atomically $ do
|
||||
players <- STM.readTMVar (scPlayers stateContainer)
|
||||
pure $ find (\p -> playerId p == clientId) players
|
||||
maybe
|
||||
(pure ())
|
||||
(\player ->
|
||||
if snd (playerLastPong player) /= uuid
|
||||
if snd (playerLastPong player) /= pongUuid
|
||||
then
|
||||
putStrLn $ "Pong ID mismatch from " <> show clientId
|
||||
putStrLn $ "Pong ID mismatch from: " <> show clientId
|
||||
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)
|
||||
{ playerLastPong = (now, pongUuid)
|
||||
}
|
||||
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
|
||||
sendUpdate stateContainer (rcMap readerContainer) player
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Server.Communication.Receive where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
|
|
@ -30,19 +31,16 @@ import Server.Types
|
|||
receiveMessage
|
||||
:: STM.TMVar Socket
|
||||
-> STM.TQueue ClientMessage
|
||||
-> STM.TMVar [ClientComms]
|
||||
-> IO ()
|
||||
receiveMessage sockContainer queue clientList = do
|
||||
receiveMessage sockContainer queue = do
|
||||
randSleep <- randomRIO (1, 1000)
|
||||
threadDelay randSleep
|
||||
msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
|
||||
sock <- STM.atomically $ STM.readTMVar sockContainer
|
||||
let maxBufferLength = 4096
|
||||
maybe
|
||||
(pure ())
|
||||
(\sock -> do
|
||||
putStrLn "took socket container for receiving"
|
||||
putStrLn "read socket container for receiving"
|
||||
mMsg <- do
|
||||
ptr <- mallocArray maxBufferLength
|
||||
putStrLn "receiving data"
|
||||
eBufferLength <-
|
||||
try $ recvBuf sock ptr maxBufferLength
|
||||
bufferLength <- case eBufferLength of
|
||||
|
|
@ -51,12 +49,13 @@ receiveMessage sockContainer queue clientList = do
|
|||
-- dropClient clientList sock
|
||||
pure 0
|
||||
Right len -> pure len
|
||||
msg <- B.pack <$> peekArray bufferLength ptr
|
||||
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
|
||||
free ptr
|
||||
if bufferLength > 0
|
||||
then
|
||||
pure mJsonMsg
|
||||
msg <- B.pack <$> peekArray bufferLength ptr
|
||||
putStrLn $ "received data: " <> show msg
|
||||
if bufferLength > 0 && msg /= ""
|
||||
then do
|
||||
putStrLn $ "received message: " <> show msg
|
||||
pure (A.decode' $ B8.fromStrict msg :: Maybe ClientMessage)
|
||||
else
|
||||
pure Nothing
|
||||
maybe
|
||||
|
|
@ -67,6 +66,3 @@ receiveMessage sockContainer queue clientList = do
|
|||
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
|
||||
)
|
||||
mMsg
|
||||
STM.atomically $ STM.putTMVar sockContainer sock
|
||||
)
|
||||
msock
|
||||
|
|
|
|||
|
|
@ -47,33 +47,30 @@ import Server.Types
|
|||
queueMessage
|
||||
:: ServerMessage
|
||||
-> UUID
|
||||
-> STM.TMVar [ClientComms]
|
||||
-> [ClientQueue]
|
||||
-> IO ()
|
||||
queueMessage msg uuid clientList = do
|
||||
clients <- STM.atomically $ STM.readTMVar clientList
|
||||
let mQueue = ccQueue <$> find (\client -> ccUUID client == Just uuid) clients
|
||||
queueMessage msg uuid queueList = do
|
||||
putStrLn $ "queueing message \"" <> show msg <> "\" for client " <> show uuid <> " …"
|
||||
let mQueue = cqQueue <$> find (\client -> cqUUID client == Just uuid) queueList
|
||||
maybe
|
||||
(putStrLn $ "unknown client UUID: " <> show uuid)
|
||||
(putStrLn $ "no queue found for client: " <> show uuid)
|
||||
(\queue ->
|
||||
STM.atomically $ STM.writeTQueue queue msg
|
||||
)
|
||||
mQueue
|
||||
putStrLn "message queued!"
|
||||
|
||||
sendMessageQueue
|
||||
:: STM.TMVar Socket
|
||||
-> STM.TQueue ServerMessage
|
||||
-> IO ()
|
||||
sendMessageQueue sockContainer queue = do
|
||||
randSleep <- randomRIO (1, 1000)
|
||||
threadDelay randSleep
|
||||
msock <- STM.atomically $ STM.tryTakeTMVar sockContainer
|
||||
maybe
|
||||
(pure ())
|
||||
(\sock -> do
|
||||
putStrLn "took socket container for sending"
|
||||
msgs <- STM.atomically $ STM.flushTQueue queue
|
||||
mapM_
|
||||
(\msg -> do
|
||||
sock <- STM.atomically $ STM.readTMVar sockContainer
|
||||
putStrLn "read socket container for sending"
|
||||
putStrLn $ "sending message: " <> show msg
|
||||
let msgJson = A.encode msg
|
||||
msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>'))
|
||||
VS.unsafeWith
|
||||
|
|
@ -88,9 +85,6 @@ sendMessageQueue sockContainer queue = do
|
|||
)
|
||||
)
|
||||
msgs
|
||||
STM.atomically $ STM.putTMVar sockContainer sock
|
||||
)
|
||||
msock
|
||||
|
||||
sendPings :: Game ()
|
||||
sendPings = do
|
||||
|
|
@ -100,54 +94,59 @@ sendPings = do
|
|||
fps <- asks rcFPS
|
||||
stateContainer <- get
|
||||
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
|
||||
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
|
||||
-- sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
|
||||
mapM_
|
||||
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
|
||||
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
|
||||
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
|
||||
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
|
||||
when (isJust clientSock) $
|
||||
if timeDiff > realToFrac maxTimeout
|
||||
then do
|
||||
liftIO $ do
|
||||
putStrLn $ "dropping client because of timeout: " <> show plId
|
||||
dropClient (scClientSockets stateContainer) (fromJust clientSock)
|
||||
put stateContainer
|
||||
else do
|
||||
-- let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
|
||||
-- when (isJust clientSock) $
|
||||
-- if timeDiff > realToFrac maxTimeout
|
||||
-- then do
|
||||
-- liftIO $ do
|
||||
-- putStrLn $ "dropping client because of timeout: " <> show plId
|
||||
-- dropClient (scClientSockets stateContainer) (fromJust clientSock)
|
||||
-- put stateContainer
|
||||
-- else do
|
||||
random <- liftIO nextRandom
|
||||
let newPong = (now, random)
|
||||
liftIO $ queueMessage
|
||||
liftIO $ do
|
||||
queues <- STM.atomically $ STM.readTMVar (scClientQueues stateContainer)
|
||||
queueMessage
|
||||
( Ping random
|
||||
)
|
||||
plId
|
||||
(scClientSockets stateContainer)
|
||||
queues
|
||||
let newPlayer = player
|
||||
{ playerLastPong = newPong
|
||||
}
|
||||
otherPlayers = filter (\a -> playerId a /= plId) players
|
||||
liftIO $ void $ STM.atomically $
|
||||
liftIO $ do
|
||||
void $ STM.atomically $
|
||||
STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
|
||||
putStrLn "ping!"
|
||||
)
|
||||
players
|
||||
put stateContainer
|
||||
|
||||
-- | Drops the client from internal management and closes its socket, if still present.
|
||||
dropClient
|
||||
:: STM.TMVar [ClientComms]
|
||||
:: STM.TMVar [ClientSocket]
|
||||
-> Socket
|
||||
-> IO ()
|
||||
dropClient clientList sock = do
|
||||
mClient <- STM.atomically $ do
|
||||
clients <- STM.readTMVar clientList
|
||||
let mclient = find (\client -> ccSocket client == sock) clients
|
||||
let reducedClients = filter (\client -> ccSocket client /= sock) clients
|
||||
let mclient = find (\client -> csSocket client == sock) clients
|
||||
let reducedClients = filter (\client -> csSocket client /= sock) clients
|
||||
void $ STM.swapTMVar clientList reducedClients
|
||||
pure mclient
|
||||
maybe
|
||||
(putStrLn $ "closing unknown socket: " <> show sock)
|
||||
(\client -> do
|
||||
putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ ccUUID client)
|
||||
killThread (ccListener client)
|
||||
putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ csUUID client)
|
||||
killThread (csSender client)
|
||||
killThread (csReceiver client)
|
||||
)
|
||||
mClient
|
||||
close sock
|
||||
|
|
@ -158,11 +157,11 @@ sendUpdate
|
|||
-> Player
|
||||
-> IO ()
|
||||
sendUpdate stateContainer tileMap player = do
|
||||
slice <- buildSlice player
|
||||
let slice = buildSlice player
|
||||
sendSlice slice player
|
||||
where
|
||||
buildSlice :: Player -> IO MapSlice
|
||||
buildSlice (Player _ (Wizard {..}) _ _) = do
|
||||
buildSlice :: Player -> MapSlice
|
||||
buildSlice (Player _ (Wizard {..}) _ _) =
|
||||
let V2 wr wc = wizardPos
|
||||
subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
|
||||
leftBound = wizardRot + (pi / 4)
|
||||
|
|
@ -185,9 +184,12 @@ sendUpdate stateContainer tileMap player = do
|
|||
Nothing
|
||||
)
|
||||
subCoords
|
||||
pure (MapSlice initViewMatrix [])
|
||||
in
|
||||
MapSlice initViewMatrix []
|
||||
sendSlice :: MapSlice -> Player -> IO ()
|
||||
sendSlice slice (Player playerId wizard _ _) = do
|
||||
let msg = TickUpdate slice wizard
|
||||
-- print slice
|
||||
liftIO $ queueMessage msg playerId (scClientSockets stateContainer)
|
||||
liftIO $ do
|
||||
queues <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer
|
||||
queueMessage msg playerId queues
|
||||
|
|
|
|||
|
|
@ -36,13 +36,13 @@ runGame = do
|
|||
let delta = realToFrac $ diffUTCTime now before
|
||||
-- liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> " \r"
|
||||
handleMessages
|
||||
updateSpawners delta
|
||||
updateWizards delta
|
||||
modify'
|
||||
(\s -> s
|
||||
{ scServerLastTick = now
|
||||
}
|
||||
)
|
||||
-- updateSpawners delta
|
||||
-- updateWizards delta
|
||||
-- modify'
|
||||
-- (\s -> s
|
||||
-- { scServerLastTick = now
|
||||
-- }
|
||||
-- )
|
||||
fps <- asks rcFPS
|
||||
sendPings
|
||||
let remainingTime = recip (fromIntegral fps) - delta
|
||||
|
|
@ -50,4 +50,3 @@ runGame = do
|
|||
liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
|
||||
)
|
||||
liftIO $ threadDelay (10 ^ 6)
|
||||
-- liftIO $ killThread recvThread
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Server.Types
|
|||
|
||||
updateSpawners :: Float -> Game ()
|
||||
updateSpawners dt =
|
||||
modify' (\sc@(StateContainer spawners _ _ _ _ _) ->
|
||||
modify' (\sc@(StateContainer spawners _ _ _ _ _ _) ->
|
||||
let newSpawners = map
|
||||
(\spawner -> do
|
||||
let newTTL = spawnerReloadTTL spawner - dt
|
||||
|
|
|
|||
|
|
@ -63,16 +63,22 @@ data StateContainer = StateContainer
|
|||
, scPlayers :: STM.TMVar [Player]
|
||||
, scServerState :: STM.TMVar ServerState
|
||||
, scServerLastTick :: UTCTime
|
||||
, scClientSockets :: STM.TMVar [ClientComms]
|
||||
, scClientSockets :: STM.TMVar [ClientSocket]
|
||||
, scClientQueues :: STM.TMVar [ClientQueue]
|
||||
, scMessageQueue :: STM.TQueue ClientMessage
|
||||
}
|
||||
|
||||
data ClientComms = ClientComms
|
||||
{ ccUUID :: Maybe UUID
|
||||
, ccSocket :: Socket
|
||||
, ccQueue :: STM.TQueue ServerMessage
|
||||
, ccWriter :: ThreadId
|
||||
, ccListener :: ThreadId
|
||||
data ClientSocket = ClientSocket
|
||||
{ csUUID :: Maybe UUID
|
||||
, csSocket :: Socket
|
||||
, csSender :: ThreadId
|
||||
, csReceiver :: ThreadId
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
data ClientQueue = ClientQueue
|
||||
{ cqUUID :: Maybe UUID
|
||||
, cqQueue :: STM.TQueue ServerMessage
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue