fix some communication issues

This commit is contained in:
nek0 2024-03-29 23:01:41 +01:00
parent be888101a0
commit 58120fbc1b
6 changed files with 64 additions and 35 deletions

View file

@ -2,6 +2,8 @@
{-# LANGUAGE RecordWildCards #-}
module Client.Communication where
import Control.Exception
import qualified Control.Concurrent.STM as STM
import Control.Monad.RWS
@ -39,15 +41,21 @@ connectSocket path = do
-- | Sends a specified message through given socket to the server
sendMessage
:: ClientMessage
:: StateContainer
-> ClientMessage
-> Socket
-> IO ()
sendMessage msg sock = do
sendMessage st msg sock = do
let msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
(\ptr -> do
eResult <- try $ sendBuf sock ptr (VS.length msgVector)
case eResult of
Left (_ :: IOException) -> gracefulExit st "Quitting due to connection loss…"
Right _ -> pure ()
)
handleMessages
:: Game ()
@ -55,7 +63,10 @@ handleMessages = do
queue <- asks rcQueue
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
handleMessage
(\msg -> do
liftIO $ print msg
handleMessage msg
)
msgs
handleMessage
@ -63,21 +74,14 @@ handleMessage
-> Game ()
handleMessage ServerQuit = do
st <- get
let stateCont = scClientState st
liftIO $ STM.atomically $ do
stateContainer <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ stateContainer
{ clientStop = True
}
put $ st
{ scClientState = stateCont
}
liftIO $ putStrLn "Quitting due to server shutdown"
liftIO (gracefulExit st "Quitting due to server shutdown")
handleMessage (Ping id') = do
cid <- asks rcClientUUID
sock <- asks rcSocket
st <- get
liftIO $ sendMessage
st
( ClientMessage
cid
(Pong id')
@ -95,14 +99,34 @@ handleMessage (TickUpdate slice wizard) = do
handleMessage x =
liftIO $ putStrLn $ "received unexpected message from server: " <> show x
-- Gracefully shut down the client with an error message
gracefulExit
:: StateContainer
-> String
-> IO ()
gracefulExit st reason = do
liftIO $ putStrLn reason
let stateCont = scClientState st
liftIO $ STM.atomically $ do
stateContainer <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ stateContainer
{ clientStop = True
}
receiveMessage
:: Socket
-> STM.TQueue ServerMessage
-> StateContainer
-> IO ()
receiveMessage sock queue = do
receiveMessage sock queue st = do
let maxBufferLength = 4096
ptr <- mallocArray maxBufferLength
bufferLength <- recvBuf sock ptr maxBufferLength
ebufferLength <- try $ recvBuf sock ptr maxBufferLength
bufferLength <- case ebufferLength of
Left (_ :: IOException) -> do
gracefulExit st "Quitting due to connection loss"
pure 0
Right len -> pure len
rawMsg <- B.pack <$> peekArray bufferLength ptr
let msgs =
if B.length rawMsg < 1
@ -125,23 +149,26 @@ terminateGameOnSigint = do
sock <- asks rcSocket
clientId <- asks rcClientUUID
clientState <- gets scClientState
st <- get
void $ liftIO $ installHandler
keyboardSignal
(CatchOnce $ do
putStrLn "SIGINT caught, terminating…"
STM.atomically $ do
currentState <- STM.readTMVar clientState
void $ STM.swapTMVar clientState $ currentState { clientStop = True }
-- Vty.shutdown (clientVty currentState)
partingMessage clientId sock
partingMessage st clientId sock
-- Raise SIGINT again so it does not get blocked
raiseSignal keyboardSignal
-- raiseSignal keyboardSignal
)
Nothing
partingMessage
:: UUID
:: StateContainer
-> UUID
-> Socket
-> IO ()
partingMessage clientId sock = do
sendMessage (ClientMessage clientId ClientQuit) sock
partingMessage st clientId sock = do
sendMessage st (ClientMessage clientId ClientQuit) sock
-- close sock

View file

@ -25,15 +25,16 @@ runGame = do
sock <- asks rcSocket
queue <- asks rcQueue
clientId <- asks rcClientUUID
recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue
liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
st <- get
recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st
liftIO $ sendMessage st(ClientMessage clientId ClientReady) sock
whileM_
(not . clientStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scClientState))
(do
handleMessages
-- draw
)
liftIO $ killThread recvThread
-- liftIO $ killThread recvThread
handleEvent
:: Maybe Event

View file

@ -36,9 +36,11 @@ main = do
queue <- STM.newTQueueIO
sendMessage (IdRequest) sock
-- threadDelay $ 1 * 10 ^ 6
receiveMessage sock queue
mockClientState <- STM.newTMVarIO (ClientState undefined False False)
let mockState = StateContainer undefined mockClientState undefined
sendMessage mockState (IdRequest) sock
receiveMessage sock queue mockState
awaitResponse queue 1
clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
let clientId = acClientUUID clientIdMsg
@ -49,9 +51,9 @@ main = do
threadDelay $ 5 * 10 ^ 6
sendMessage (ClientMessage clientId ClientRequestWizard) sock
sendMessage mockState (ClientMessage clientId ClientRequestWizard) sock
-- threadDelay $ 1 * 10 ^ 6
receiveMessage sock queue
receiveMessage sock queue mockState
awaitResponse queue 1
playerWizard <- head <$> STM.atomically (STM.flushTQueue queue)
putStrLn $ "received wizard: " <> show (initWizard playerWizard)
@ -77,7 +79,7 @@ main = do
initRead
initState
-- shutdown vty
partingMessage clientId sock
partingMessage initState clientId sock
threadDelay 100
close sock
where

View file

@ -70,7 +70,7 @@ main = do
)
initRead
initState
-- removeIfExists setSocketPath
removeIfExists setSocketPath
threadDelay 1000
putStrLn "bye bye"
where

View file

@ -73,7 +73,7 @@ terminateGameOnSigint path = do
putStrLn "SIGINT caught, terminating…"
disconnectClients clientList clients
close sock
removeIfExists path
-- removeIfExists path
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
)
Nothing

View file

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Server.Game where
import Control.Concurrent (threadDelay)
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
@ -9,8 +9,6 @@ import Control.Monad.RWS.Strict
import Control.Monad.Loops
import Control.Concurrent
import qualified Data.ByteString.Char8 as B8
import Data.Time
@ -53,7 +51,8 @@ runGame = do
when (remainingTime > 0) $
liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
)
liftIO $ killThread recvThread
liftIO $ threadDelay (10 ^ 6)
-- liftIO $ killThread recvThread
updateSpawners :: Float -> Game ()
updateSpawners dt =