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

include some failsafes

Browse source
This commit is contained in:
nek0 2023-12-12 02:53:05 +01:00
parent afa21eaece
commit 9691a0412a
5 changed files with 61 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
configuration.yaml
View file

@ -2,4 +2,4 @@ setSocketPath : "/tmp/wizard.sock"
setMapRows : 20
setMapColumns : 20
setSpawnerProbability : 0.01
setFPS : 5
setFPS : 30

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

@ -54,6 +54,6 @@ receiveMessage sock queue = do
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg
maybe
(pure ())
(putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict msg))
(STM.atomically . STM.writeTQueue queue)
mJsonMsg

25
src-client/Main.hs
View file

@ -5,6 +5,8 @@ import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.STM as STM
import Control.Monad.Loops (whileM_)
import Options.Applicative
-- internal imports
@ -22,24 +24,33 @@ main = do
sock <- connectSocket socketLocation
queue <- STM.newTQueueIO
putStrLn "connected"
sendMessage (IdRequest) sock
threadDelay $ 1 * 10 ^ 6
receiveMessage sock queue
threadDelay $ 1 * 10 ^ 6
whileM_
(STM.atomically $ STM.isEmptyTQueue queue)
(threadDelay $ 1 * 10 ^ 6)
clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
let clientId = acClientUUID clientIdMsg
putStrLn $ "received client UUID: " <> show clientId
threadDelay $ 1 * 10 ^ 6
putStrLn welcomeText
threadDelay $ 15 * 10 ^ 6
putStrLn welcomeText
-- threadDelay $ 15 * 10 ^ 6
sendMessage (ClientMessage clientId ClientRequestWizard) sock
threadDelay $ 1 * 10 ^ 6
receiveMessage sock queue
threadDelay $ 1 * 10 ^ 6
whileM_
(STM.atomically $ STM.isEmptyTQueue queue)
(threadDelay $ 1 * 10 ^ 6)
playerWizard <- head <$> STM.atomically (STM.flushTQueue queue)
putStrLn "received wizard"
print (initWizard playerWizard)
putStrLn $ "received wizard: " <> show (initWizard playerWizard)
let initRead = ReaderContainer sock clientId
initState = StateContainer (initWizard playerWizard)
putStrLn "sending quit message"

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

@ -10,6 +10,7 @@ import GHC.Generics
-- internal imports
import Library.Types.Player
import Library.Types.Map
data ServerMessage
= ServerQuit

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

@ -110,6 +110,7 @@ sendMessage
sendMessage msg sock = do
let msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
putStrLn $ "sending: " <> B8.unpack msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
@ -125,7 +126,10 @@ processMessages = do
mapM_
(\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do
receiveMessage clientSocket queue
handleMessage serverState readerContainer
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
(handleMessage serverState readerContainer)
msgs
)
clients
@ -151,6 +155,7 @@ receiveMessage sock queue = do
(pure ())
(\msg -> do
liftIO $ STM.atomically $ STM.writeTQueue queue msg
when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
mmsg
@ -158,48 +163,42 @@ receiveMessage sock queue = do
handleMessage
:: StateContainer
-> ReaderContainer
-> ClientMessage
-> IO ()
handleMessage stateContainer readerContainer = do
let queue = scMessageQueue stateContainer
clientList = scClientSockets stateContainer
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
handleMessage stateContainer readerContainer msg = do
let clientList = scClientSockets stateContainer
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
mapM_
(\msg -> liftIO $ do
putStrLn "Handling following:"
print msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (\a -> fst a == Nothing) clients
let clientSock = snd $ clients !! fromJust clientIdx
sendMessage (AcceptClient clientId) clientSock
putStrLn $ "Accepted Client with UUID " <> show clientId
let newClients = map
(\old@(muuid, oldClientSock) ->
if oldClientSock == clientSock && muuid == Nothing
then
(Just clientId, clientSock)
else
old
)
clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
ClientMessage clientId payload ->
case payload of
ClientQuit -> do
putStrLn $ "removing client " <> show clientId
let newClients = filter (\a -> fst a /= Just clientId) clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
let clientSock = fromJust $ lookup (Just clientId) clients
sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
_ -> pure ()
)
msgs
putStrLn $ "Handling following: " <> show msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (\a -> fst a == Nothing) clients
let clientSock = snd $ clients !! fromJust clientIdx
let newClients = map
(\old@(muuid, oldClientSock) ->
if oldClientSock == clientSock && muuid == Nothing
then
(Just clientId, clientSock)
else
old
)
clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
putStrLn $ "Accepted Client with UUID " <> show clientId
sendMessage (AcceptClient clientId) clientSock
ClientMessage clientId payload ->
case payload of
ClientQuit -> do
putStrLn $ "removing client " <> show clientId
let newClients = filter (\a -> fst a /= Just clientId) clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
let clientSock = fromJust $ lookup (Just clientId) clients
sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
_ -> pure ()
newWizard
:: Position