introduce logging

This commit is contained in:
nek0 2024-11-04 06:53:58 +01:00
parent 8dd03d2558
commit d76447400d
8 changed files with 106 additions and 70 deletions

View file

@ -5,3 +5,4 @@ setSpawnerProbability : 0.01
setFPS : 30
setClientMaxTimeout : 5
setFramesPerPing : 120
setLogLevel : Verbose

View file

@ -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

View file

@ -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

View file

@ -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
)

View file

@ -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
)

View file

@ -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

View file

@ -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)

View file

@ -72,6 +72,7 @@ executable wizard-wipeout-server
Server.Communication.Send
Server.Game
Server.Game.Update
Server.Log
Server.Map
Server.Types
Server.Util