From d76447400dd84b2f877c89ab08d5391dfb2680e7 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 4 Nov 2024 06:53:58 +0100 Subject: [PATCH] introduce logging --- configuration.yaml | 1 + src-server/Main.hs | 15 ++++--- src-server/Server/Communication.hs | 44 +++++++++++--------- src-server/Server/Communication/Handler.hs | 26 ++++++------ src-server/Server/Communication/Receive.hs | 31 +++++++------- src-server/Server/Communication/Send.hs | 47 +++++++++++++--------- src-server/Server/Types.hs | 11 +++++ wizard-wipeout.cabal | 1 + 8 files changed, 106 insertions(+), 70 deletions(-) diff --git a/configuration.yaml b/configuration.yaml index f332f95..61ad583 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -5,3 +5,4 @@ setSpawnerProbability : 0.01 setFPS : 30 setClientMaxTimeout : 5 setFramesPerPing : 120 +setLogLevel : Verbose diff --git a/src-server/Main.hs b/src-server/Main.hs index 0767f4e..0f65df6 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -27,6 +27,7 @@ import Library.Types import Server.Communication import Server.Game +import Server.Log import Server.Map (generateArena) import Server.Types import Server.Util @@ -44,14 +45,15 @@ main = do ) Right (Settings {..}) -> do sock <- bindSocket setSocketPath - putStrLn "Bound and listening to socket:" - print =<< getSocketName sock - putStrLn "-----------------------------------------------------------------------------------" + let logLevel = setLogLevel + logPrintIO logLevel Info "Bound and listening to socket:" + logPrintIO logLevel Info . show =<< getSocketName sock + logPrintIO logLevel Info "-----------------------------------------------------------------------------------" arena <- generateArena setMapRows setMapColumns setSpawnerProbability - putStrLn "generated arena:" + logPrintIO logLevel Info "generated arena:" prettyPrintMap (arenaMap arena) - putStrLn "-----------------------------------------------------------------------------------" - putStrLn "starting game…" + logPrintIO logLevel Info "-----------------------------------------------------------------------------------" + logPrintIO logLevel Info "starting game…" now <- getCurrentTime sockList <- STM.newTMVarIO [] queueList <- STM.newTMVarIO [] @@ -64,6 +66,7 @@ main = do setFramesPerPing setClientMaxTimeout sock + logLevel initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList queueList messageQueue (finalState, finalWrite) <- execRWST (do diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 13c408c..a5ccb1a 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -31,6 +31,7 @@ import Library.Types import Server.Communication.Handler as S import Server.Communication.Receive as S import Server.Communication.Send as S +import Server.Log (logPrintIO) import Server.Types -- | Function which determines whether the given filePath is a supported socket path and @@ -53,14 +54,15 @@ terminateGameOnSigint :: Game () terminateGameOnSigint = do sock <- asks rcMainSocket + curLevel <- asks rcLogLevel serverState <- gets scServerState clientList <- gets scClientSockets queueList <- gets scClientQueues void $ liftIO $ installHandler sigINT (CatchOnce $ do - putStrLn "SIGINT caught, terminating…" - disconnectClients clientList queueList + logPrintIO curLevel Info "SIGINT caught, terminating…" + disconnectClients curLevel clientList queueList threadDelay (10 ^ 6) close sock st <- STM.atomically $ STM.readTMVar serverState @@ -72,24 +74,25 @@ terminateGameOnSigint = do -- | Disconnect all connected clients gracefully by announcing the server quitting disconnectClients - :: STM.TMVar [ClientSocket] + :: LogLevel + -> STM.TMVar [ClientSocket] -> STM.TMVar [ClientQueue] -> IO () -disconnectClients clientSockets queueList = do - putStrLn "server shutting down. Notifying all clients…" +disconnectClients curLevel clientSockets queueList = do + logPrintIO curLevel Info "server shutting down. Notifying all clients…" queues <- STM.atomically $ STM.readTMVar queueList mapM_ (\queue -> do maybe (pure ()) (\uuid -> do - putStrLn $ "notifying client: " <> show uuid - queueMessage ServerQuit uuid queueList + logPrintIO curLevel Info $ "notifying client: " <> show uuid + queueMessage curLevel ServerQuit uuid queueList threadDelay 1000 -- wait for the message to be actually sent sock <- do socketList <- STM.atomically $ STM.readTMVar clientSockets pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList - dropClient clientSockets queueList (csSocket sock) + dropClient curLevel clientSockets queueList (csSocket sock) ) (cqUUID queue) ) @@ -100,28 +103,33 @@ disconnectClients clientSockets queueList = do processRequests :: Game () processRequests = do mainSocket <- asks rcMainSocket + curLevel <- asks rcLogLevel serverQueue <- gets scMessageQueue socketList <- gets scClientSockets queueList <- gets scClientQueues st <- gets scServerState - void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queueList serverQueue st + void $ liftIO $ forkIO $ acceptConnection curLevel mainSocket socketList queueList serverQueue st where - acceptConnection mainSocket socketList queueList serverQueue st = do - putStrLn "Ready for new connection requests…" + acceptConnection curLevel mainSocket socketList queueList serverQueue st = do + logPrintIO curLevel Info "Ready for new connection requests…" eSock <- try $ accept mainSocket case eSock of Left (_ :: SomeException) -> - putStrLn "Main socket vanished!" + logPrintIO curLevel Warning "Main socket vanished!" Right (clientSock, _) -> do clientQueue <- STM.newTQueueIO sockContainer <- STM.newTMVarIO clientSock receiverThreadId <- liftIO $ do - t <- forkIO $ forever $ receiveMessage sockContainer serverQueue - -- putStrLn "enabled listener thread" + t <- forkIO $ do + threadDelay $ 10 ^ 6 + forever $ receiveMessage curLevel socketList queueList mainSocket serverQueue + logPrintIO curLevel Verbose "enabled listener thread" pure t senderThreadId <- liftIO $ do - t <- forkIO $ forever $ sendMessageQueue sockContainer clientQueue - -- putStrLn "enabled sender thread" + t <- forkIO $ do + threadDelay $ 10 ^ 6 + forever $ sendMessageQueue curLevel sockContainer clientQueue + logPrintIO curLevel Verbose "enabled sender thread" pure t print clientSock liftIO $ STM.atomically $ do @@ -142,8 +150,8 @@ processRequests = do clientQueue : qlist ) - putStrLn "accepted new connection" + logPrintIO curLevel Info "accepted new connection" -- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) -- unless abortCondition $ -- acceptConnection mainSocket socketList queue st - acceptConnection mainSocket socketList queueList serverQueue st + acceptConnection curLevel mainSocket socketList queueList serverQueue st diff --git a/src-server/Server/Communication/Handler.hs b/src-server/Server/Communication/Handler.hs index 34eb91b..e806841 100644 --- a/src-server/Server/Communication/Handler.hs +++ b/src-server/Server/Communication/Handler.hs @@ -20,6 +20,7 @@ import Data.UUID.V4 import Library.Types import Server.Communication.Send +import Server.Log import Server.Types import Server.Util @@ -32,9 +33,10 @@ handleMessage handleMessage stateContainer readerContainer msg = do let socketList = scClientSockets stateContainer queueList = scClientQueues stateContainer + curLevel = rcLogLevel readerContainer socks <- liftIO $ STM.atomically $ STM.readTMVar socketList queues <- liftIO $ STM.atomically $ STM.readTMVar queueList - -- putStrLn $ "Handling: " <> show msg + logPrintIO curLevel Verbose $ "Handling: " <> show msg case msg of IdRequest -> do clientId <- nextRandom @@ -55,21 +57,20 @@ handleMessage stateContainer readerContainer msg = do 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 queueList + logPrintIO curLevel Info $ "Accepted Client with UUID: " <> show clientId + queueMessage curLevel (AcceptClient clientId) clientId queueList else - putStrLn $ "Unable to assign ID to socket and queue: " <> show clientId + logPrintIO curLevel Error $ "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 currentPlayers <- STM.atomically $ STM.readTMVar (scPlayers stateContainer) let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers void $ STM.atomically $ STM.swapTMVar (scPlayers stateContainer) newPlayers let client = find (\a -> csUUID a == Just clientId) socks - dropClient socketList queueList (csSocket $ fromJust client) + dropClient curLevel socketList queueList (csSocket $ fromJust client) + logPrintIO curLevel Info $ "client has quit the game: " <> show clientId ClientRequestWizard -> do - putStrLn "initializing new wizard" let arena = rcMap readerContainer initPos <- rollInitPosition arena now <- liftIO getCurrentTime @@ -79,7 +80,8 @@ 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 curLevel (ProvideInitialWizard freshWizard) clientId queueList + logPrintIO curLevel Info $ "initialized new wizard for: " <> show clientId ClientReady -> do now <- getCurrentTime STM.atomically $ do @@ -93,12 +95,12 @@ handleMessage stateContainer readerContainer msg = do , playerLastPong = (now, snd (playerLastPong $ head thisPlayers)) } : otherPlayers - putStrLn $ "client ready: " <> show clientId + logPrintIO curLevel Info $ "client ready: " <> show clientId Pong pongUuid -> do let mclient = find (\c -> csUUID c == Just clientId) socks players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer) maybe - (putStrLn $ "Unknown client: " <> show clientId) + (logPrintIO curLevel Warning $ "Unknown client: " <> show clientId) (const $ do mPlayer <- STM.atomically $ do pure $ find (\p -> playerId p == clientId) players @@ -107,7 +109,7 @@ handleMessage stateContainer readerContainer msg = do (\player -> if snd (playerLastPong player) /= pongUuid then - putStrLn $ "Pong ID mismatch from: " <> show clientId + logPrintIO curLevel Warning $ "Pong ID mismatch from: " <> show clientId else do now <- getCurrentTime STM.atomically$ do @@ -116,7 +118,7 @@ handleMessage stateContainer readerContainer msg = do { playerLastPong = (now, pongUuid) } void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) - sendUpdate stateContainer (rcMap readerContainer) player + sendUpdate curLevel stateContainer (rcMap readerContainer) player ) mPlayer ) diff --git a/src-server/Server/Communication/Receive.hs b/src-server/Server/Communication/Receive.hs index db0f33f..182bf75 100644 --- a/src-server/Server/Communication/Receive.hs +++ b/src-server/Server/Communication/Receive.hs @@ -25,45 +25,48 @@ import System.Random import Library.Types import Server.Communication.Send +import Server.Log (logPrintIO) import Server.Types -- | receive a 'ClientMessage' receiveMessage - :: STM.TMVar Socket + :: LogLevel + -> STM.TMVar [ClientSocket] + -> STM.TMVar [ClientQueue] + -> Socket -> STM.TQueue ClientMessage -> IO () -receiveMessage sockContainer queue = do - -- randSleep <- randomRIO (1, 1000) - -- threadDelay randSleep - sock <- STM.atomically $ STM.readTMVar sockContainer +receiveMessage curLevel socketList queueList sock queue = do + randSleep <- randomRIO (1, 1000) + threadDelay randSleep let maxBufferLength = 4096 - putStrLn "read socket container for receiving" + logPrintIO curLevel Verbose "read socket container for receiving" ptr <- mallocArray maxBufferLength - putStrLn "receiving data" + logPrintIO curLevel Verbose "receiving data" eBufferLength <- try $ recvBuf sock ptr maxBufferLength - putStrLn $ "received raw buffer length of: " <> show eBufferLength + logPrintIO curLevel Verbose $ "received raw buffer length of: " <> show eBufferLength bufferLength <- case eBufferLength of Left (e :: IOException) -> do - -- putStrLn ("Socket vanished, cleaning up after " <> show e) - -- dropClient clientList sock + logPrintIO curLevel Warning ("Socket vanished, cleaning up after " <> show e) + dropClient curLevel socketList queueList sock pure 0 Right len -> pure len - putStrLn $ "received buffer of length: " <> show bufferLength + logPrintIO curLevel Verbose $ "received buffer of length: " <> show bufferLength rawMsg <- B.pack <$> peekArray bufferLength ptr free ptr - putStrLn $ "received data: " <> show rawMsg + logPrintIO curLevel Verbose $ "received data: " <> show rawMsg let msgs = if B.length rawMsg < 1 then [] :: [B8.ByteString] else map B8.tail $ init $ B8.split '>' $ B8.fromStrict rawMsg - putStrLn $ "received messages: " <> show msgs + logPrintIO curLevel Verbose $ "received messages: " <> show msgs print msgs mapM_ (\msg -> do let mJsonMsg = A.decode' msg maybe - (putStrLn $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg)) + (logPrintIO curLevel Warning $ "received garbled data: " <> B8.unpack (B8.fromStrict rawMsg)) (\jsonMsg -> do STM.atomically $ STM.writeTQueue queue jsonMsg ) diff --git a/src-server/Server/Communication/Send.hs b/src-server/Server/Communication/Send.hs index 08afd8b..05b727a 100644 --- a/src-server/Server/Communication/Send.hs +++ b/src-server/Server/Communication/Send.hs @@ -41,40 +41,43 @@ import System.Random (randomRIO) import Library.Types +import Server.Log (logPrintIO, logPrint) import Server.Types -- | Sends a specified message through given socket to the client queueMessage - :: ServerMessage + :: LogLevel + -> ServerMessage -> UUID -> STM.TMVar [ClientQueue] -> IO () -queueMessage msg uuid queueListContainer = do +queueMessage curLevel msg uuid queueListContainer = do queueList <- STM.atomically $ STM.readTMVar queueListContainer - putStrLn $ "queueing message \"" <> show msg <> "\" for client " <> show uuid <> " …" + logPrintIO curLevel Verbose $ "queueing message \"" <> show msg <> "\" for client " <> show uuid <> " …" let mQueue = cqQueue <$> find (\client -> cqUUID client == Just uuid) queueList maybe - (putStrLn $ "no queue found for client: " <> show uuid) + (logPrintIO curLevel Warning $ "no queue found for client: " <> show uuid) (\queue -> STM.atomically $ STM.writeTQueue queue msg ) mQueue - putStrLn "message queued!" + logPrintIO curLevel Verbose "message queued!" sendMessageQueue - :: STM.TMVar Socket + :: LogLevel + -> STM.TMVar Socket -> STM.TQueue ServerMessage -> IO () -sendMessageQueue sockContainer queue = do +sendMessageQueue curLevel sockContainer queue = do -- randTime <- randomRIO (1, 1000) -- threadDelay randTime msgs <- STM.atomically $ STM.flushTQueue queue - unless (null msgs) $ putStrLn $ "messages in queue: " <> show msgs + unless (null msgs) $ logPrintIO curLevel Verbose $ "messages in queue: " <> show msgs mapM_ (\msg -> do sock <- STM.atomically $ STM.readTMVar sockContainer - putStrLn "read socket container for sending" - putStrLn $ "sending message: " <> show msg + logPrintIO curLevel Verbose "read socket container for sending" + logPrintIO curLevel Verbose $ "sending message: " <> show msg let msgJson = A.encode msg msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>')) VS.unsafeWith @@ -83,7 +86,7 @@ sendMessageQueue sockContainer queue = do eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector) case eResult of Left (e :: IOException) -> - putStrLn $ "can't reach client after " <> show e + logPrintIO curLevel Error $ "can't reach client after " <> show e Right _ -> pure () ) @@ -95,6 +98,7 @@ sendPings = do now <- liftIO getCurrentTime maxTimeout <- asks rcClientMaxTimeout framesPerPing <- asks rcFramesPerPing + curLevel <- asks rcLogLevel fps <- asks rcFPS stateContainer <- get players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) @@ -117,6 +121,7 @@ sendPings = do liftIO $ do let queues = scClientQueues stateContainer queueMessage + curLevel ( Ping random ) plId @@ -128,31 +133,32 @@ sendPings = do liftIO $ do void $ STM.atomically $ STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers) - putStrLn "ping!" + logPrintIO curLevel Verbose "ping!" ) players put stateContainer -- | Drops the client from internal management and closes its socket, if still present. dropClient - :: STM.TMVar [ClientSocket] + :: LogLevel + -> STM.TMVar [ClientSocket] -> STM.TMVar [ClientQueue] -> Socket -> IO () -dropClient socketList queueList sock = do +dropClient curLevel socketList queueList sock = do clients <- STM.atomically $ STM.readTMVar socketList mClient <- STM.atomically $ do let mclient = find (\client -> csSocket client == sock) clients pure mclient maybe - (putStrLn $ "closing unknown socket: " <> show sock) + (logPrintIO curLevel Warning $ "closing unknown socket: " <> show sock) (\client -> do - putStrLn $ "killing client sender and listener because of socket closing: " <> show (fromJust $ csUUID client) + logPrintIO curLevel Info $ "killing client sender and listener because of socket closing: " <> show (fromJust $ csUUID client) killThread (csSender client) killThread (csReceiver client) + logPrintIO curLevel Info $ "dropping client because of socket closing: " <> show (fromJust $ csUUID client) ) mClient - putStrLn $ "dropping client because of socket closing: " <> show (fromJust $ csUUID $ fromJust mClient) STM.atomically $ do queues <- STM.readTMVar queueList let reducedClients = filter (\client -> csSocket client /= sock) clients @@ -162,11 +168,12 @@ dropClient socketList queueList sock = do close sock sendUpdate - :: StateContainer + :: LogLevel + -> StateContainer -> ServerMap -> Player -> IO () -sendUpdate stateContainer tileMap player = do +sendUpdate curLevel stateContainer tileMap player = do let slice = buildSlice player sendSlice slice player where @@ -202,4 +209,4 @@ sendUpdate stateContainer tileMap player = do -- print slice liftIO $ do let queues = scClientQueues stateContainer - queueMessage msg playerId queues + queueMessage curLevel msg playerId queues diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index dbce0b5..dc2406e 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -31,11 +31,21 @@ data Settings = Settings , setFPS :: Int , setClientMaxTimeout :: Float , setFramesPerPing :: Int + , setLogLevel :: LogLevel } deriving (Show, Generic) instance Aeson.FromJSON Settings +data LogLevel + = Error + | Warning + | Info + | Verbose + deriving (Show, Generic, Eq, Ord) + +instance Aeson.FromJSON LogLevel + newtype Options = Options { optConfLoc :: FilePath } @@ -55,6 +65,7 @@ data ReaderContainer = ReaderContainer , rcFramesPerPing :: Int , rcClientMaxTimeout :: Float , rcMainSocket :: Socket + , rcLogLevel :: LogLevel } deriving (Eq, Show) diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index 9f8cfa4..605266b 100644 --- a/wizard-wipeout.cabal +++ b/wizard-wipeout.cabal @@ -72,6 +72,7 @@ executable wizard-wipeout-server Server.Communication.Send Server.Game Server.Game.Update + Server.Log Server.Map Server.Types Server.Util