fix communication

This commit is contained in:
nek0 2024-04-19 20:18:49 +02:00
parent 65e0c5d272
commit ab4a2a4130
6 changed files with 76 additions and 89 deletions

View file

@ -20,12 +20,8 @@ import Data.IORef
import Data.UUID import Data.UUID
import qualified Data.Vector.Storable as VS
import Foreign hiding (void) import Foreign hiding (void)
import Graphics.Vty as Vty
import Network.Socket import Network.Socket
import System.Posix.Signals import System.Posix.Signals
@ -46,11 +42,10 @@ connectSocket path = do
-- | Sends a specified message through given socket to the server -- | Sends a specified message through given socket to the server
sendMessage sendMessage
:: StateContainer :: ClientMessage
-> ClientMessage
-> Socket -> Socket
-> IO () -> IO ()
sendMessage st msg sock = do sendMessage msg sock = do
let msgJson = A.encode msg let msgJson = A.encode msg
msgList = B.unpack $ B.toStrict msgJson msgList = B.unpack $ B.toStrict msgJson
ptr <- newArray msgList ptr <- newArray msgList
@ -79,9 +74,7 @@ handleMessage ServerQuit = do
handleMessage (Ping id') = do handleMessage (Ping id') = do
cid <- asks rcClientUUID cid <- asks rcClientUUID
sock <- asks rcSocket sock <- asks rcSocket
st <- get
liftIO $ sendMessage liftIO $ sendMessage
st
( ClientMessage ( ClientMessage
cid cid
(Pong id') (Pong id')
@ -106,12 +99,7 @@ gracefulExit
-> IO () -> IO ()
gracefulExit st reason = do gracefulExit st reason = do
liftIO $ putStrLn reason liftIO $ putStrLn reason
let stateCont = scClientState st writeIORef (scStopper st) True
liftIO $ STM.atomically $ do
stateContainer <- STM.readTMVar stateCont
void $ STM.swapTMVar stateCont $ stateContainer
{ clientStop = True
}
receiveMessage receiveMessage
:: Socket :: Socket
@ -148,10 +136,12 @@ terminateGameOnSigint
:: IORef Bool :: IORef Bool
-> Game () -> Game ()
terminateGameOnSigint stopper = do terminateGameOnSigint stopper = do
rc <- ask
void $ liftIO $ installHandler void $ liftIO $ installHandler
keyboardSignal keyboardSignal
(CatchOnce $ do (CatchOnce $ do
putStrLn "receiveMessage: SIGINT caught, terminating…" putStrLn "receiveMessage: SIGINT caught, terminating…"
liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc)
atomicWriteIORef stopper True atomicWriteIORef stopper True
-- Vty.shutdown (clientVty currentState) -- Vty.shutdown (clientVty currentState)
-- Raise SIGINT again so it does not get blocked -- Raise SIGINT again so it does not get blocked
@ -160,10 +150,9 @@ terminateGameOnSigint stopper = do
Nothing Nothing
partingMessage partingMessage
:: StateContainer :: UUID
-> UUID
-> Socket -> Socket
-> IO () -> IO ()
partingMessage st clientId sock = do partingMessage clientId sock = do
sendMessage st (ClientMessage clientId ClientQuit) sock putStrLn "sending parting message to server…"
-- close sock sendMessage (ClientMessage clientId ClientQuit) sock

View file

@ -1,16 +1,10 @@
module Client.Game where module Client.Game where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Loops import Control.Monad.Loops
import Control.Monad.RWS import Control.Monad.RWS
import Data.IORef (IORef, readIORef) import Data.IORef (readIORef)
import Graphics.Vty import Graphics.Vty
@ -23,23 +17,21 @@ import Client.Types
import Library.Types import Library.Types
runGame runGame
:: IORef Bool :: Game ()
-> Game () runGame = do
runGame stopper = do
sock <- asks rcSocket sock <- asks rcSocket
queue <- asks rcQueue queue <- asks rcQueue
clientId <- asks rcClientUUID clientId <- asks rcClientUUID
st <- get st <- get
-- recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st -- recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st
liftIO $ sendMessage st(ClientMessage clientId ClientReady) sock liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
whileM_ whileM_
(liftIO (not <$> readIORef stopper)) (liftIO (not <$> readIORef (scStopper st)))
(do (do
liftIO $ receiveMessage sock queue st liftIO $ receiveMessage sock queue st
handleMessages handleMessages
-- draw -- draw
) )
liftIO $ partingMessage st clientId sock
-- liftIO $ killThread recvThread -- liftIO $ killThread recvThread
handleEvent handleEvent

View file

@ -6,6 +6,8 @@ import Control.Exception (Exception)
import Control.Monad.RWS import Control.Monad.RWS
import Data.IORef (IORef)
import Data.UUID import Data.UUID
import Network.Socket import Network.Socket
@ -37,6 +39,7 @@ data StateContainer = StateContainer
{ scWizard :: Wizard { scWizard :: Wizard
, scClientState :: STM.TMVar ClientState , scClientState :: STM.TMVar ClientState
, scMapSlice :: MapSlice , scMapSlice :: MapSlice
, scStopper :: IORef Bool
} }
type Game = RWST ReaderContainer String StateContainer IO type Game = RWST ReaderContainer String StateContainer IO

View file

@ -14,8 +14,6 @@ import qualified Data.Matrix as M
import Graphics.Vty import Graphics.Vty
import Network.Socket (close)
import Options.Applicative import Options.Applicative
-- internal imports -- internal imports
@ -39,9 +37,9 @@ main = do
-- threadDelay $ 1 * 10 ^ 6 -- threadDelay $ 1 * 10 ^ 6
mockClientState <- STM.newTMVarIO (ClientState undefined False False) mockClientState <- STM.newTMVarIO (ClientState undefined False)
let mockState = StateContainer undefined mockClientState undefined let mockState = StateContainer undefined mockClientState undefined undefined
sendMessage mockState (IdRequest) sock sendMessage IdRequest sock
receiveMessage sock queue mockState receiveMessage sock queue mockState
awaitResponse queue 1 awaitResponse queue 1
clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue) clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
@ -53,7 +51,7 @@ main = do
threadDelay $ 5 * 10 ^ 6 threadDelay $ 5 * 10 ^ 6
sendMessage mockState (ClientMessage clientId ClientRequestWizard) sock sendMessage (ClientMessage clientId ClientRequestWizard) sock
-- threadDelay $ 1 * 10 ^ 6 -- threadDelay $ 1 * 10 ^ 6
receiveMessage sock queue mockState receiveMessage sock queue mockState
awaitResponse queue 1 awaitResponse queue 1
@ -67,17 +65,17 @@ main = do
-- shut down graphical interface for now -- shut down graphical interface for now
-- shutdown vty -- shutdown vty
clientState <- STM.newTMVarIO (ClientState undefined False False) stopper <- newIORef False
clientState <- STM.newTMVarIO (ClientState undefined False)
let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) [] let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
let initRead = ReaderContainer sock clientId queue let initRead = ReaderContainer sock clientId queue
initState = StateContainer (initWizard playerWizard) clientState initSlice initState = StateContainer (initWizard playerWizard) clientState initSlice stopper
-- putStrLn "sending quit message" -- putStrLn "sending quit message"
-- sendMessage (ClientMessage clientId ClientQuit) sock -- sendMessage (ClientMessage clientId ClientQuit) sock
stopper <- newIORef False
void $ execRWST void $ execRWST
(do (do
terminateGameOnSigint stopper terminateGameOnSigint stopper
runGame stopper runGame
) )
initRead initRead
initState initState

View file

@ -16,7 +16,6 @@ import Data.Aeson (ToJSON, FromJSON)
data ClientState = ClientState data ClientState = ClientState
{ clientVty :: Vty -- ^ Context object for graphics { clientVty :: Vty -- ^ Context object for graphics
, clientGameOver :: Bool -- ^ client game over (contestant died) , clientGameOver :: Bool -- ^ client game over (contestant died)
, clientStop :: Bool -- ^ client shutdown
} }
-- | Type synonym for the Map. Translates to a Matrix of 'Tile's -- | Type synonym for the Map. Translates to a Matrix of 'Tile's

View file

@ -62,13 +62,13 @@ terminateGameOnSigint
:: Game () :: Game ()
terminateGameOnSigint = do terminateGameOnSigint = do
sock <- asks rcMainSocket sock <- asks rcMainSocket
clientList <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
serverState <- gets scServerState serverState <- gets scServerState
clientList <- gets scClientSockets
void $ liftIO $ installHandler void $ liftIO $ installHandler
sigINT sigINT
(CatchOnce $ do (CatchOnce $ do
putStrLn "SIGINT caught, terminating…" putStrLn "SIGINT caught, terminating…"
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
disconnectClients clientList clients disconnectClients clientList clients
close sock close sock
st <- STM.atomically $ STM.readTMVar serverState st <- STM.atomically $ STM.readTMVar serverState
@ -83,16 +83,19 @@ disconnectClients
:: STM.TMVar [ClientComms] :: STM.TMVar [ClientComms]
-> [ClientComms] -> [ClientComms]
-> IO () -> IO ()
disconnectClients clientList = mapM_ disconnectClients clientList clients = do
(\client -> do putStrLn "server shutting down. Notifying all clients…"
maybe mapM_
(pure ()) (\client -> do
(\uuid -> do maybe
sendMessage ServerQuit uuid clientList (pure ())
dropClient clientList (ccSocket client) (\uuid -> do
) sendMessage ServerQuit uuid clientList
(ccUUID client) dropClient clientList (ccSocket client)
) )
(ccUUID client)
)
clients
-- | Drops the client from internal management and closes its socket, if still present. -- | Drops the client from internal management and closes its socket, if still present.
dropClient dropClient
@ -126,8 +129,8 @@ processRequests = do
where where
acceptConnection mainSocket socketList queue st = do acceptConnection mainSocket socketList queue st = do
putStrLn "Ready for new connection requests…" putStrLn "Ready for new connection requests…"
esock <- try $ accept mainSocket eSock <- try $ accept mainSocket
case esock of case eSock of
Left (_ :: SomeException) -> Left (_ :: SomeException) ->
putStrLn "Main socket vanished!" putStrLn "Main socket vanished!"
Right (clientSock, _) -> do Right (clientSock, _) -> do
@ -135,7 +138,7 @@ processRequests = do
receiveMessage clientSock queue socketList receiveMessage clientSock queue socketList
liftIO $ STM.atomically $ do liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList list <- STM.takeTMVar socketList
STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list) STM.putTMVar socketList (ClientComms Nothing clientSock clientThreadId : list)
putStrLn "accepted new connection" putStrLn "accepted new connection"
abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
unless abortCondition $ unless abortCondition $
@ -150,7 +153,7 @@ sendMessage
-> IO () -> IO ()
sendMessage msg uuid clientList = do sendMessage msg uuid clientList = do
clients <- STM.atomically $ STM.readTMVar clientList clients <- STM.atomically $ STM.readTMVar clientList
let msock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients let mSock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
msgJson = A.encode msg msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>')) msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
putStrLn $ "Sending: " <> B8.unpack msgJson putStrLn $ "Sending: " <> B8.unpack msgJson
@ -159,9 +162,16 @@ sendMessage msg uuid clientList = do
(\sock -> (\sock ->
VS.unsafeWith VS.unsafeWith
msgVector msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) (\ptr -> do
eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector)
case eResult of
Left (_ :: IOException) ->
putStrLn $ "cant reach client " <> show uuid
Right _ ->
pure ()
)
) )
msock mSock
-- | handle received messages -- | handle received messages
handleMessages :: Game () handleMessages :: Game ()
@ -177,7 +187,6 @@ handleMessages = do
pure [] pure []
else else
STM.flushTQueue queue STM.flushTQueue queue
unless (null msgs) $ putStrLn "GET"
void $ do void $ do
mapM_ mapM_
(handleMessage serverState readerContainer) (handleMessage serverState readerContainer)
@ -191,11 +200,11 @@ receiveMessage
-> IO () -> IO ()
receiveMessage sock queue clientList = do receiveMessage sock queue clientList = do
let maxBufferLength = 4096 let maxBufferLength = 4096
mmsg <- do mMsg <- do
ptr <- mallocArray maxBufferLength ptr <- mallocArray maxBufferLength
ebufferLength <- eBufferLength <-
try $ recvBuf sock ptr maxBufferLength try $ recvBuf sock ptr maxBufferLength
bufferLength <- case ebufferLength of bufferLength <- case eBufferLength of
Left (_ :: IOException) -> do Left (_ :: IOException) -> do
putStrLn "Socket vanished, cleaning up…" putStrLn "Socket vanished, cleaning up…"
dropClient clientList sock dropClient clientList sock
@ -212,11 +221,10 @@ receiveMessage sock queue clientList = do
maybe maybe
(pure ()) (pure ())
(\msg -> do (\msg -> do
putStrLn "PUT"
liftIO $ STM.atomically $ STM.writeTQueue queue msg liftIO $ STM.atomically $ STM.writeTQueue queue msg
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3) -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
) )
mmsg mMsg
-- | function for translating 'ClientMessage's into server actions -- | function for translating 'ClientMessage's into server actions
handleMessage handleMessage
@ -232,10 +240,10 @@ handleMessage stateContainer readerContainer msg = do
IdRequest -> do IdRequest -> do
clientId <- nextRandom clientId <- nextRandom
let clientIdx = findIndex (isNothing . ccUUID) clients let clientIdx = findIndex (isNothing . ccUUID) clients
let clientSock = ccSocket $ clients !! fromJust clientIdx clientSock = ccSocket $ clients !! fromJust clientIdx
let newClients = map newClients = map
(\old@(ClientComms muuid oldClientSock _) -> (\old@(ClientComms mUUID oldClientSock _) ->
if oldClientSock == clientSock && isNothing muuid if oldClientSock == clientSock && isNothing mUUID
then then
old old
{ ccUUID = Just clientId { ccUUID = Just clientId
@ -250,15 +258,9 @@ handleMessage stateContainer readerContainer msg = do
ClientMessage clientId payload -> ClientMessage clientId payload ->
case payload of case payload of
ClientQuit -> do ClientQuit -> do
putStrLn $ "removing client " <> show clientId putStrLn $ "client " <> show clientId <> " has quit the game"
let newClients = filter (\a -> ccUUID a /= Just clientId) clients let client = find (\a -> ccUUID a == Just clientId) clients
client = find (\a -> ccUUID a == Just clientId) clients dropClient clientList (ccSocket $ fromJust client)
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
void $ STM.swapTMVar (scPlayers stateContainer) newPlayers
void $ STM.swapTMVar clientList newClients
close (ccSocket $ fromJust client)
ClientRequestWizard -> do ClientRequestWizard -> do
putStrLn "initializing new wizard" putStrLn "initializing new wizard"
let arena = rcMap readerContainer let arena = rcMap readerContainer
@ -273,28 +275,32 @@ handleMessage stateContainer readerContainer msg = do
sendMessage (ProvideInitialWizard freshWizard) clientId clientList sendMessage (ProvideInitialWizard freshWizard) clientId clientList
ClientReady -> do ClientReady -> do
putStrLn $ "client " <> show clientId <> " is ready!" putStrLn $ "client " <> show clientId <> " is ready!"
now <- getCurrentTime
STM.atomically $ do STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer) currentPlayers <- STM.readTMVar (scPlayers stateContainer)
let (thisPlayers, otherPlayers) = let (thisPlayers, otherPlayers) =
partition (\p -> playerId p == clientId) currentPlayers partition (\p -> playerId p == clientId) currentPlayers
unless (null thisPlayers) $ unless (null thisPlayers) $
void $ STM.swapTMVar (scPlayers stateContainer) $ void $ STM.swapTMVar (scPlayers stateContainer) $
(head thisPlayers) {playerReady = True} : otherPlayers (head thisPlayers)
{ playerReady = True
, playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
}
: otherPlayers
Pong uuid -> do Pong uuid -> do
let mclient = find (\c -> ccUUID c == Just clientId) clients let mclient = find (\c -> ccUUID c == Just clientId) clients
maybe maybe
(putStrLn $ "Who is " <> show uuid <> "?") (putStrLn $ "Who is " <> show uuid <> "?")
(\client -> do (\_ -> do
mplayer <- STM.atomically $ do mPlayer <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer) players <- STM.readTMVar (scPlayers stateContainer)
pure $ find (\p -> playerId p == clientId) players pure $ find (\p -> playerId p == clientId) players
maybe maybe
(pure ()) (pure ())
(\player -> (\player ->
if snd (playerLastPong player) /= uuid if snd (playerLastPong player) /= uuid
then do then
putStrLn $ "dropping client " <> show clientId putStrLn $ "Pong ID mismatch from " <> show clientId
dropClient clientList (ccSocket client)
else do else do
now <- getCurrentTime now <- getCurrentTime
STM.atomically$ do STM.atomically$ do
@ -305,7 +311,7 @@ handleMessage stateContainer readerContainer msg = do
} }
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
) )
mplayer mPlayer
) )
mclient mclient
@ -330,7 +336,7 @@ sendPings = do
put stateContainer put stateContainer
else do else do
random <- liftIO nextRandom random <- liftIO nextRandom
let newPong = (now, random) let newPong = (lastPongTime, random)
liftIO $ sendMessage liftIO $ sendMessage
( Ping random ( Ping random
) )