From 473d9dea6e5c576612225e558098a4b532b31b3a Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 2 Nov 2024 23:37:15 +0100 Subject: [PATCH] trying to decouple sending and receiving in server --- configuration.yaml | 2 +- src-client/Client/Communication.hs | 5 +- src-client/Client/Game.hs | 6 ++- src-client/Main.hs | 9 ++-- src-server/Server/Communication.hs | 14 ++--- src-server/Server/Communication/Handler.hs | 2 +- src-server/Server/Communication/Receive.hs | 60 +++++++++++++--------- src-server/Server/Communication/Send.hs | 53 +++++++++++-------- 8 files changed, 95 insertions(+), 56 deletions(-) diff --git a/configuration.yaml b/configuration.yaml index 12bc274..f332f95 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,6 +2,6 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 40 setMapColumns : 40 setSpawnerProbability : 0.01 -setFPS : 60 +setFPS : 30 setClientMaxTimeout : 5 setFramesPerPing : 120 diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index 01ef064..231923f 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -30,6 +30,7 @@ import System.Posix.Signals import Library.Types import Client.Types +import GHC.Conc (threadDelay) connectSocket :: FilePath @@ -46,6 +47,7 @@ sendMessage -> Socket -> IO () sendMessage msg sock = do + print msg let msgJson = A.encode msg msgList = B.unpack $ B.toStrict msgJson ptr <- newArray msgList @@ -153,5 +155,6 @@ partingMessage -> Socket -> IO () partingMessage clientId sock = do - putStrLn "sending parting message to server…" sendMessage (ClientMessage clientId ClientQuit) sock + putStrLn "sent parting message to server" + threadDelay (10 ^ 6) diff --git a/src-client/Client/Game.hs b/src-client/Client/Game.hs index 65d536e..cbc55a1 100644 --- a/src-client/Client/Game.hs +++ b/src-client/Client/Game.hs @@ -1,5 +1,7 @@ module Client.Game where +import Control.Concurrent (threadDelay) + import Control.Concurrent.STM (atomically, readTMVar) import Control.Monad.Loops @@ -35,4 +37,6 @@ runGame = do handleEvents draw ) - liftIO $ sendMessage (ClientMessage clientId ClientQuit) sock + liftIO $ do + partingMessage clientId sock + threadDelay (10 ^ 6) diff --git a/src-client/Main.hs b/src-client/Main.hs index f6cef0b..ad2ebb8 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -15,6 +15,8 @@ import qualified Data.Matrix as M import Graphics.Vty import Graphics.Vty.CrossPlatform +import Network.Socket (close) + import Options.Applicative -- internal imports @@ -80,11 +82,12 @@ main = do ) initRead initState + putStrLn "Shutting down client…" showCursor (outputIface vty) shutdown vty - putStrLn "Shutting down client…" - -- threadDelay 100 - -- close sock + threadDelay (10 ^ 6) + putStrLn "Closing connection to server…" + close sock putStrLn "bye bye" where opts = info (options <**> helper) diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 43e7537..2c4a85a 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -78,6 +78,7 @@ disconnectClients clientList clients = do maybe (pure ()) (\uuid -> do + putStrLn $ "notifying client: " <> show uuid queueMessage ServerQuit uuid clientList dropClient clientList (ccSocket client) ) @@ -103,11 +104,11 @@ processRequests = do putStrLn "Main socket vanished!" Right (clientSock, _) -> do messageQueue <- STM.newTQueueIO - sockCOntainer <- STM.newTMVarIO clientSock + sockContainer <- STM.newTMVarIO clientSock clientWriteThreadId <- liftIO $ forkIO $ forever $ do - receiveMessage sockCOntainer queue socketList + receiveMessage sockContainer queue socketList clientListenThreadId <- liftIO $ forkIO $ forever $ do - sendMessageQueue sockCOntainer messageQueue + sendMessageQueue sockContainer messageQueue print clientSock liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList @@ -122,6 +123,7 @@ processRequests = do : list ) putStrLn "accepted new connection" - abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) - unless abortCondition $ - acceptConnection mainSocket socketList queue st + -- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) + -- unless abortCondition $ + -- acceptConnection mainSocket socketList queue st + acceptConnection mainSocket socketList queue st diff --git a/src-server/Server/Communication/Handler.hs b/src-server/Server/Communication/Handler.hs index 8ad1ecb..38aaf52 100644 --- a/src-server/Server/Communication/Handler.hs +++ b/src-server/Server/Communication/Handler.hs @@ -53,7 +53,7 @@ handleMessage stateContainer readerContainer msg = do ClientMessage clientId payload -> case payload of ClientQuit -> do - putStrLn $ "client " <> show clientId <> " has quit the game" + putStrLn $ "client has quit the game: " <> show clientId let client = find (\a -> ccUUID a == Just clientId) clients dropClient clientList (ccSocket $ fromJust client) ClientRequestWizard -> do diff --git a/src-server/Server/Communication/Receive.hs b/src-server/Server/Communication/Receive.hs index e29b41e..4e3e624 100644 --- a/src-server/Server/Communication/Receive.hs +++ b/src-server/Server/Communication/Receive.hs @@ -1,5 +1,7 @@ module Server.Communication.Receive where +import Control.Concurrent (threadDelay) + import qualified Control.Concurrent.STM as STM import Control.Exception @@ -15,6 +17,8 @@ import Foreign.Marshal hiding (void) import Network.Socket +import System.Random + -- internal imports import Library.Types @@ -29,30 +33,40 @@ receiveMessage -> STM.TMVar [ClientComms] -> IO () receiveMessage sockContainer queue clientList = do - sock <- STM.atomically $ STM.readTMVar sockContainer + randSleep <- randomRIO (1, 1000) + threadDelay randSleep + msock <- STM.atomically $ STM.tryTakeTMVar sockContainer let maxBufferLength = 4096 - mMsg <- do - ptr <- mallocArray maxBufferLength - eBufferLength <- - try $ recvBuf sock ptr maxBufferLength - 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 - msg <- B.pack <$> peekArray bufferLength ptr - let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage - free ptr - if bufferLength > 0 - then - pure mJsonMsg - else - pure Nothing maybe (pure ()) - (\msg -> do - liftIO $ STM.atomically $ STM.writeTQueue queue msg - -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) + (\sock -> do + putStrLn "took socket container for receiving" + mMsg <- do + ptr <- mallocArray maxBufferLength + eBufferLength <- + try $ recvBuf sock ptr maxBufferLength + 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 + msg <- B.pack <$> peekArray bufferLength ptr + let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage + free ptr + if bufferLength > 0 + then + pure mJsonMsg + else + pure Nothing + maybe + (pure ()) + (\msg -> do + print msg + liftIO $ STM.atomically $ STM.writeTQueue queue msg + -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) + ) + mMsg + STM.atomically $ STM.putTMVar sockContainer sock ) - mMsg + msock diff --git a/src-server/Server/Communication/Send.hs b/src-server/Server/Communication/Send.hs index dd5a6fe..cb0a0b0 100644 --- a/src-server/Server/Communication/Send.hs +++ b/src-server/Server/Communication/Send.hs @@ -35,6 +35,8 @@ import Linear import Network.Socket +import System.Random (randomRIO) + -- internal imports import Library.Types @@ -62,24 +64,33 @@ sendMessageQueue -> STM.TQueue ServerMessage -> IO () sendMessageQueue sockContainer queue = do - sock <- STM.atomically $ STM.readTMVar sockContainer - msgs <- STM.atomically $ STM.flushTQueue queue - mapM_ - (\msg -> do - let msgJson = A.encode msg - msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>')) - VS.unsafeWith - msgVector - (\ptr -> do - eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector) - case eResult of - Left (e :: IOException) -> - putStrLn $ "can't reach client after " <> show e - Right _ -> - pure () + randSleep <- randomRIO (1, 1000) + threadDelay randSleep + msock <- STM.atomically $ STM.tryTakeTMVar sockContainer + maybe + (pure ()) + (\sock -> do + putStrLn "took socket container for sending" + msgs <- STM.atomically $ STM.flushTQueue queue + mapM_ + (\msg -> do + let msgJson = A.encode msg + msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>')) + VS.unsafeWith + msgVector + (\ptr -> do + eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector) + case eResult of + Left (e :: IOException) -> + putStrLn $ "can't reach client after " <> show e + Right _ -> + pure () + ) ) + msgs + STM.atomically $ STM.putTMVar sockContainer sock ) - msgs + msock sendPings :: Game () sendPings = do @@ -98,7 +109,9 @@ sendPings = do when (isJust clientSock) $ if timeDiff > realToFrac maxTimeout then do - liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock) + liftIO $ do + putStrLn $ "dropping client because of timeout: " <> show plId + dropClient (scClientSockets stateContainer) (fromJust clientSock) put stateContainer else do random <- liftIO nextRandom @@ -131,9 +144,9 @@ dropClient clientList sock = do void $ STM.swapTMVar clientList reducedClients pure mclient maybe - (pure ()) -- putStrLn $ "closing unknown socket: " <> show sock) + (putStrLn $ "closing unknown socket: " <> show sock) (\client -> do - putStrLn $ "dropping client: " <> show (fromJust $ ccUUID client) + putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ ccUUID client) killThread (ccListener client) ) mClient @@ -176,5 +189,5 @@ sendUpdate stateContainer tileMap player = do sendSlice :: MapSlice -> Player -> IO () sendSlice slice (Player playerId wizard _ _) = do let msg = TickUpdate slice wizard - print slice + -- print slice liftIO $ queueMessage msg playerId (scClientSockets stateContainer)