make server non-blocking

This commit is contained in:
nek0 2023-12-11 10:48:25 +01:00
parent d245129461
commit bd890800c5
3 changed files with 26 additions and 14 deletions

View file

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

View file

@ -23,6 +23,9 @@ main = do
threadDelay $ 5 * 10 ^ 6 threadDelay $ 5 * 10 ^ 6
clientId <- receiveMessage sock clientId <- receiveMessage sock
putStrLn $ "received client UUID: " <> show (acClientUUID clientId) putStrLn $ "received client UUID: " <> show (acClientUUID clientId)
threadDelay $ 5 * 10 ^ 6
putStrLn "sending quit message"
sendMessage (ClientMessage (acClientUUID clientId) ClientQuit) sock
where where
opts = info (options <**> helper) opts = info (options <**> helper)
( fullDesc ( fullDesc

View file

@ -20,6 +20,7 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.UUID
import Data.UUID.V4 import Data.UUID.V4
import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable as VS
@ -75,6 +76,7 @@ terminateGameOnSigint = do
where where
disconnectClients = mapM_ disconnectClients = mapM_
(\(_, clientSocket) -> do (\(_, clientSocket) -> do
sendMessage ServerQuit clientSocket
close clientSocket close clientSocket
) )
@ -111,20 +113,22 @@ processMessages :: Game ()
processMessages = do processMessages = do
clientsVar <- gets scClientSockets clientsVar <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
queue <- gets scMessageQueue
mapM_ mapM_
(\(uuid, clientSocket) -> do (\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do
receiveMessage clientSocket receiveMessage clientSocket queue
handleMessage handleMessage queue clientsVar
) )
clients clients
-- | receive a 'ClientMessage' -- | receive a 'ClientMessage'
receiveMessage receiveMessage
:: Socket :: Socket
-> Game () -> STM.TQueue ClientMessage
receiveMessage sock = do -> IO ()
receiveMessage sock queue = do
let maxBufferLength = 4096 let maxBufferLength = 4096
mmsg <- liftIO $ do mmsg <- do
ptr <- mallocArray maxBufferLength ptr <- mallocArray maxBufferLength
bufferLength <- recvBuf sock ptr maxBufferLength bufferLength <- recvBuf sock ptr maxBufferLength
msg <- B.pack <$> peekArray bufferLength ptr msg <- B.pack <$> peekArray bufferLength ptr
@ -138,18 +142,17 @@ receiveMessage sock = do
maybe maybe
(pure ()) (pure ())
(\msg -> do (\msg -> do
queue <- gets scMessageQueue
liftIO $ STM.atomically $ STM.writeTQueue queue msg liftIO $ STM.atomically $ STM.writeTQueue queue msg
) )
mmsg mmsg
-- | function for translating 'ClientMessage's into server actions -- | function for translating 'ClientMessage's into server actions
handleMessage handleMessage
:: Game () :: STM.TQueue ClientMessage
handleMessage = do -> STM.TMVar [(Maybe UUID, Socket)]
queue <- gets scMessageQueue -> IO ()
handleMessage queue clientList = do
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
clientList <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
mapM_ mapM_
(\msg -> liftIO $ do (\msg -> liftIO $ do
@ -172,6 +175,12 @@ handleMessage = do
) )
clients clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients 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
_ -> pure () _ -> pure ()
) )
msgs msgs