nek0/wizard-wipeout
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

fix communication

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

29
src-client/Client/Communication.hs
View file

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

18
src-client/Client/Game.hs
View file

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

3
src-client/Client/Types.hs
View file

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

18
src-client/Main.hs
View file

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

1
src-lib/Library/Types/Map.hs
View file

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

96
src-server/Server/Communication.hs
View file

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