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
setMapColumns : 20
setSpawnerProbability : 0.01
setFPS : 1
setFPS : 5

View file

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

View file

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