diff --git a/configuration.yaml b/configuration.yaml index 1cd7bd3..f332f95 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,6 +2,6 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 40 setMapColumns : 40 setSpawnerProbability : 0.01 -setFPS : 1 +setFPS : 30 setClientMaxTimeout : 5 setFramesPerPing : 120 diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 231923f..31e545c 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -47,11 +47,13 @@ sendMessage -> Socket -> IO () sendMessage msg sock = do - print msg + putStrLn $ "sending message: " <> show msg let msgJson = A.encode msg msgList = B.unpack $ B.toStrict msgJson + putStrLn $ "sending raw message buffer: " <> show msgList ptr <- newArray msgList void $ sendBuf sock ptr (length msgList) + putStrLn "raw message buffer sent" free ptr handleMessages @@ -109,16 +111,19 @@ receiveMessage sock queue st = do let maxBufferLength = 4096 ptr <- mallocArray maxBufferLength ebufferLength <- try $ recvBuf sock ptr maxBufferLength + -- putStrLn $ "received buffer of length: " <> show ebufferLength 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 + -- putStrLn $ "received raw message: " <> show rawMsg let msgs = if B.length rawMsg < 1 then [] else map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg + -- putStrLn $ "resulting split messages: " <> show msgs mapM_ (\msg -> do let mJsonMsg = A.decode' msg diff --git a/src-client/Client/Game.hs b/src-client/Client/Game.hs index cbc55a1..788eda3 100644 --- a/src-client/Client/Game.hs +++ b/src-client/Client/Game.hs @@ -28,15 +28,22 @@ runGame = do st <- get vty <- clientVty <$> liftIO (atomically $ readTMVar (scClientState st)) liftIO $ sendMessage (ClientMessage clientId ClientReady) sock + liftIO $ putStrLn "entering game loop" whileM_ (liftIO (not <$> readIORef (scStopper st))) (do liftIO $ receiveMessage sock messageQueue st + -- liftIO $ putStrLn "received messages" handleMessages + -- liftIO $ putStrLn "handled messages" pumpEvents vty + -- liftIO $ putStrLn "pumped events" handleEvents + -- liftIO $ putStrLn "handled events" draw + -- liftIO $ putStrLn "drew" ) liftIO $ do + liftIO $ putStrLn "left game loop" partingMessage clientId sock threadDelay (10 ^ 6) diff --git a/src-client/Main.hs b/src-client/Main.hs index fd9bde2..4b32f38 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -73,9 +73,11 @@ main = do initState = StateContainer (initWizard playerWizard) clientState initSlice stopper -- putStrLn "sending quit message" -- sendMessage (ClientMessage clientId ClientQuit) sock + putStrLn "entering Game Monad" void $ execRWST (do terminateGameOnSigint stopper + liftIO $ putStrLn "entering main game function" runGame ) initRead diff --git a/src-server/Server/Communication/Handler.hs b/src-server/Server/Communication/Handler.hs index d239f67..e242afd 100644 --- a/src-server/Server/Communication/Handler.hs +++ b/src-server/Server/Communication/Handler.hs @@ -28,35 +28,40 @@ handleMessage -> ClientMessage -> IO () handleMessage stateContainer readerContainer msg = do - let clientList = scClientSockets stateContainer - queueList <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer - clients <- liftIO $ STM.atomically $ STM.readTMVar clientList + let socketList = scClientSockets stateContainer + queueList = scClientQueues stateContainer + socks <- liftIO $ STM.atomically $ STM.readTMVar socketList + queues <- liftIO $ STM.atomically $ STM.readTMVar queueList -- putStrLn $ "Handling: " <> show msg case msg of IdRequest -> do clientId <- nextRandom - let clientIdx = findIndex (isNothing . csUUID) clients - clientSock = csSocket $ clients !! fromJust clientIdx - newClients = map - (\old@(ClientSocket mUUID oldClientSock _ _) -> - if oldClientSock == clientSock && isNothing mUUID - then - old - { csUUID = Just clientId - } - else - old - ) - clients - void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients - putStrLn $ "Accepted Client with UUID " <> show clientId - queueMessage (AcceptClient clientId) clientId queueList + let clientIdx = findIndex (isNothing . csUUID) socks + sock = socks !! fromJust clientIdx + queue = queues !! fromJust clientIdx + if csUUID sock == cqUUID queue + then do + let otherSocks = delete sock socks + newSocks = sock + { csUUID = Just clientId + } : otherSocks + otherQueues = delete queue queues + newQueues = queue + { cqUUID = Just clientId + } : otherQueues + liftIO $ STM.atomically $ do + void $ STM.swapTMVar socketList newSocks + void $ STM.swapTMVar queueList newQueues + putStrLn $ "Accepted Client with UUID: " <> show clientId + queueMessage (AcceptClient clientId) clientId newQueues + else + putStrLn $ "Unable to assign ID to Socket and queue: " <> show clientId ClientMessage clientId payload -> case payload of ClientQuit -> do putStrLn $ "client has quit the game: " <> show clientId - let client = find (\a -> csUUID a == Just clientId) clients - dropClient clientList (csSocket $ fromJust client) + let client = find (\a -> csUUID a == Just clientId) socks + dropClient socketList (csSocket $ fromJust client) ClientRequestWizard -> do putStrLn "initializing new wizard" let arena = rcMap readerContainer @@ -68,7 +73,7 @@ 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 queueList + queueMessage (ProvideInitialWizard freshWizard) clientId queues ClientReady -> do now <- getCurrentTime STM.atomically $ do @@ -84,7 +89,7 @@ handleMessage stateContainer readerContainer msg = do : otherPlayers putStrLn $ "client ready: " <> show clientId Pong pongUuid -> do - let mclient = find (\c -> csUUID c == Just clientId) clients + let mclient = find (\c -> csUUID c == Just clientId) socks players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer) maybe (putStrLn $ "Unknown client: " <> show clientId) diff --git a/src-server/Server/Communication/Receive.hs b/src-server/Server/Communication/Receive.hs index 7381e39..597f282 100644 --- a/src-server/Server/Communication/Receive.hs +++ b/src-server/Server/Communication/Receive.hs @@ -35,21 +35,23 @@ receiveMessage receiveMessage sockContainer queue = do randSleep <- randomRIO (1, 1000) threadDelay randSleep - sock <- STM.atomically $ STM.readTMVar sockContainer + sock <- STM.atomically $ STM.takeTMVar sockContainer let maxBufferLength = 4096 - putStrLn "read socket container for receiving" + putStrLn "took socket container for receiving" mMsg <- do ptr <- mallocArray maxBufferLength putStrLn "receiving data" eBufferLength <- try $ recvBuf sock ptr maxBufferLength + putStrLn $ "received raw buffer length of: " <> show eBufferLength + free ptr bufferLength <- case eBufferLength of Left (e :: IOException) -> do -- putStrLn ("Socket vanished, cleaning up after " <> show e) -- dropClient clientList sock pure 0 Right len -> pure len - free ptr + putStrLn $ "received buffer of length: " <> show bufferLength msg <- B.pack <$> peekArray bufferLength ptr putStrLn $ "received data: " <> show msg if bufferLength > 0 && msg /= "" diff --git a/src-server/Server/Communication/Send.hs b/src-server/Server/Communication/Send.hs index 29afd30..1273da8 100644 --- a/src-server/Server/Communication/Send.hs +++ b/src-server/Server/Communication/Send.hs @@ -65,6 +65,8 @@ sendMessageQueue -> STM.TQueue ServerMessage -> IO () sendMessageQueue sockContainer queue = do + randTime <- randomRIO (1, 1000) + threadDelay randTime msgs <- STM.atomically $ STM.flushTQueue queue mapM_ (\msg -> do