From cda2ffaed465f91d78f74b89ff017ad08f8d6ed9 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 10 Dec 2023 06:57:48 +0100 Subject: [PATCH] implement proper non-blocking socket handling --- src-server/Main.hs | 17 ++++-- src-server/Server/Communication.hs | 87 +++++++++++++++++++++--------- src-server/Server/Game.hs | 28 +++++++--- src-server/Server/Types.hs | 12 +++-- wizard-wipeout.cabal | 1 + 5 files changed, 105 insertions(+), 40 deletions(-) diff --git a/src-server/Main.hs b/src-server/Main.hs index db3a309..fc8a017 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import qualified Control.Concurrent.STM as STM + import Control.Monad.RWS.Strict import qualified Data.ByteString.Char8 as B8 @@ -16,7 +18,6 @@ import Network.Socket as Net import Options.Applicative - -- internal imports import Library.Types @@ -39,8 +40,6 @@ main = do ) Right (Settings {..}) -> do sock <- bindSocket setSocketPath - terminateSocketOnSigint sock - -- Net.listen sock 1024 putStrLn "Bound and listening to socket:" print =<< getSocketName sock putStrLn "-----------------------------------------------------------------------------------" @@ -50,9 +49,17 @@ main = do putStrLn "-----------------------------------------------------------------------------------" putStrLn "starting game…" now <- getCurrentTime + sockList <- STM.newTMVarIO [] + serverState <- STM.newTMVarIO (ServerState False False) let initRead = ReaderContainer (arenaMap arena) setFPS sock - initState = StateContainer (arenaSpawners arena) [] (ServerState False False) now [] - (finalState, finalWrite) <- execRWST runGame initRead initState + initState = StateContainer (arenaSpawners arena) [] serverState now sockList + (finalState, finalWrite) <- execRWST + (do + terminateGameOnSigint + runGame + ) + initRead + initState print finalWrite where opts = info (options <**> helper) diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index bb84bc9..1a8b38d 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -1,12 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Server.Communication where +import Control.Concurrent + +import qualified Control.Concurrent.STM as STM + import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Loops + import Control.Monad.RWS.Strict +import Data.Maybe (maybe) + import Network.Socket as Net import System.IO @@ -17,6 +25,7 @@ import System.Posix.Signals import Server.Types import Server.Util +import Data.Maybe (isNothing) -- | Function which determines whether the given filePath is a supported socket path and -- subsequently creates a socket in said location. @@ -33,14 +42,19 @@ bindSocket path = do Net.listen sock 5 pure sock --- | Function that installs a handler on SIGINT to close and remove the given socket -terminateSocketOnSigint - :: Socket -- ^ Socket to terminate on termination - -> IO () -terminateSocketOnSigint sock = - void $ installHandler +-- | Function that installs a handler on SIGINT to terminate game +terminateGameOnSigint + :: Game () +terminateGameOnSigint = do + sock <- asks rcMainSocket + clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets + serverState <- gets scServerState + void $ liftIO $ installHandler keyboardSignal (CatchOnce $ do + void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True) + disconnectClients clients + threadDelay (10 ^ 6) (SockAddrUnix path) <- getSocketName sock close' sock removeIfExists path @@ -48,29 +62,52 @@ terminateSocketOnSigint sock = raiseSignal keyboardSignal ) Nothing + where + disconnectClients = mapM_ + (\(clientSocket, mThread) -> do + maybe (pure ()) killThread mThread + close' clientSocket + ) -- | Process incoming connection requests -processRequests :: Game +processRequests :: Game () processRequests = do mainSocket <- asks rcMainSocket - clientSock <- liftIO $ do - (clientSock, _) <- accept mainSocket - putStrLn $ "accepted new connection" - pure clientSock - modify' (\st -> - st - {scClientSockets = clientSock : scClientSockets st} - ) + socketList <- gets scClientSockets + serverState <- gets scServerState + void $ liftIO $ forkIO $ acceptConnection mainSocket socketList serverState + where + acceptConnection mainSocket socketList serverState = whileM_ + (not . serverStop <$> liftIO (STM.atomically $ STM.readTMVar serverState)) + (do + (clientSock, _) <- accept mainSocket + putStrLn "accepted new connection" + liftIO $ STM.atomically $ do + list <- STM.takeTMVar socketList + STM.putTMVar socketList ((clientSock, Nothing) : list) + ) --- | process incomeing messages from clients -processMessages :: Game +-- | process incoming messages from clients +processMessages :: Game () processMessages = do - clientSocks <- gets scClientSockets - mapM_ - (\clientSocket -> liftIO $ do - connectionHandle <- socketToHandle clientSocket ReadMode - hSetBuffering connectionHandle LineBuffering - messages <- hGetContents' connectionHandle - print messages + clientsVar <- gets scClientSockets + clients <- liftIO $ STM.atomically $ STM.readTMVar $ clientsVar + newClients <- mapM + (\client@(clientSocket, mThread) -> + if isNothing mThread + then liftIO $ do + connectionHandle <- socketToHandle clientSocket ReadMode + thread <- forkIO + (listenTo connectionHandle) + pure (clientSocket, Just thread) + else + pure client ) - clientSocks + clients + liftIO $ STM.atomically $ do + void $ STM.swapTMVar clientsVar newClients + where + listenTo connectionHandle = do + hSetBuffering connectionHandle LineBuffering + message <- hGetContents' connectionHandle + putStr message diff --git a/src-server/Server/Game.hs b/src-server/Server/Game.hs index a2b0758..0362b28 100644 --- a/src-server/Server/Game.hs +++ b/src-server/Server/Game.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} module Server.Game where -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay, killThread) + +import qualified Control.Concurrent.STM as STM import Control.Monad.RWS.Strict import Control.Monad.Loops +import qualified Data.ByteString.Char8 as B8 + import Data.Time +import Data.String (fromString) + +import System.IO (stdout) + -- internal imports import Library.Types @@ -15,26 +24,31 @@ import Library.Types import Server.Communication import Server.Types -runGame :: Game +runGame :: Game () runGame = do + processRequests whileM_ - (not . serverStop <$> gets scServerState) + (not . serverStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scServerState)) (do before <- gets scServerLastTick now <- liftIO getCurrentTime let delta = realToFrac $ diffUTCTime now before - - processRequests + liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> " \r" processMessages updateSpawners delta updateWizards delta + modify' + (\s -> s + { scServerLastTick = now + } + ) fps <- asks rcFPS let remainingTime = recip (fromIntegral fps) - delta when (remainingTime > 0) $ liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6 ) -updateSpawners :: Float -> Game +updateSpawners :: Float -> Game () updateSpawners dt = modify' (\sc@(StateContainer spawners _ _ _ _) -> let newSpawners = map @@ -55,7 +69,7 @@ updateSpawners dt = } ) -updateWizards :: Float -> Game +updateWizards :: Float -> Game () updateWizards dt = modify' (\sc@(StateContainer _ wizards _ _ _) -> let newWizards = map diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 74fa717..aafda78 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -1,6 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} module Server.Types where +import Control.Concurrent (ThreadId) + +import qualified Control.Concurrent.STM as STM + import Control.Monad.RWS.Strict import qualified Data.Aeson as Aeson @@ -13,6 +17,8 @@ import Network.Socket import Options.Applicative as O +--internal imports + import Library.Types data Settings = Settings @@ -49,9 +55,9 @@ data ReaderContainer = ReaderContainer data StateContainer = StateContainer { scSpawners :: [ Spawner ] , scPlayers :: [ Wizard ] - , scServerState :: ServerState + , scServerState :: STM.TMVar ServerState , scServerLastTick :: UTCTime - , scClientSockets :: [ Socket ] + , scClientSockets :: STM.TMVar [ (Socket, Maybe ThreadId) ] } -- | Data object for storing the server's state @@ -61,4 +67,4 @@ data ServerState = ServerState } deriving (Show, Eq) -type Game = RWST ReaderContainer String StateContainer IO () +type Game = RWST ReaderContainer String StateContainer IO diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index b3227d9..54324fb 100644 --- a/wizard-wipeout.cabal +++ b/wizard-wipeout.cabal @@ -63,6 +63,7 @@ executable wizard-wipeout-server , text , time , random + , stm , unix , wizard-wipeout , yaml