introduce logging

configuration.yaml

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

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:"
+      let logLevel = setLogLevel
-      print =<< getSocketName sock
+      logPrintIO logLevel Info "Bound and listening to socket:"
-      putStrLn "-----------------------------------------------------------------------------------"
+      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 "-----------------------------------------------------------------------------------"
+      logPrintIO logLevel Info "-----------------------------------------------------------------------------------"
-      putStrLn "starting game…"
+      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

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…"
+      logPrintIO curLevel Info "SIGINT caught, terminating…"
-      disconnectClients clientList queueList
+      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
+disconnectClients curLevel clientSockets queueList = do
-  putStrLn "server shutting down. Notifying all clients…"
+  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
+          logPrintIO curLevel Info $ "notifying client: " <> show uuid
-          queueMessage ServerQuit uuid queueList
+          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
+    acceptConnection curLevel mainSocket socketList queueList serverQueue st = do
-      putStrLn "Ready for new connection requests…"
+      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
+            t <- forkIO $ do
-            -- putStrLn "enabled listener thread"
+              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
+            t <- forkIO $ do
-            -- putStrLn "enabled sender thread"
+              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

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
+        logPrintIO curLevel Info $ "Accepted Client with UUID: " <> show clientId
-        queueMessage (AcceptClient clientId) clientId queueList
+        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
             )

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
+receiveMessage curLevel socketList queueList sock queue = do
-  -- randSleep <- randomRIO (1, 1000)
+  randSleep <- randomRIO (1, 1000)
-  -- threadDelay randSleep
+  threadDelay randSleep
-  sock <- STM.atomically $ STM.readTMVar sockContainer
   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)
+      logPrintIO curLevel Warning ("Socket vanished, cleaning up after " <> show e)
-      -- dropClient clientList sock
+      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
         )

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"
+      logPrintIO curLevel Verbose "read socket container for sending"
-      putStrLn $ "sending message: " <> show msg
+      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

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)
 

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