make client logging sensible

src-client/Client/Communication.hs

@@ -28,6 +28,7 @@ import System.Posix.Signals
 -- internal imports
 
 import Library.Types
+import Client.Log
 import Client.Types
 import GHC.Conc (threadDelay)
 
@@ -42,17 +43,18 @@ connectSocket path = do
 
 -- | Sends a specified message through given socket to the server
 sendMessage
-  :: ClientMessage
+  :: LogLevel
+  -> ClientMessage
   -> Socket
   -> IO ()
-sendMessage msg sock = do
+sendMessage curLevel msg sock = do
-  putStrLn $ "sending message: " <> show msg
+  logPrintIO curLevel Verbose $ "sending message: " <> show msg
   let msgJson = ('<' `B8.cons` A.encode msg) `B8.snoc` '>'
       msgList = B.unpack $ B.toStrict msgJson
-  putStrLn $ "sending raw message buffer: " <> show msgList
+  logPrintIO curLevel Verbose $ "sending raw message buffer: " <> show msgList
   ptr <- newArray msgList
   void $ sendBuf sock ptr (length msgList)
-  putStrLn "raw message buffer sent"
+  logPrintIO curLevel Verbose "raw message buffer sent"
   free ptr
 
 handleMessages
@@ -69,14 +71,16 @@ handleMessage
   -> Game ()
 handleMessage ServerQuit = do
   st <- get
-  liftIO $ do
+  logPrint Info "Quitting due to server shutdown"
-    putStrLn "Quitting due to server shutdown"
+  liftIO $
     writeIORef (scStopper st) True
 
 handleMessage (Ping id') = do
   cid <- asks rcClientUUID
   sock <- asks rcSocket
+  curLevel <- asks rcLogLevel
   liftIO $ sendMessage
+    curLevel
     ( ClientMessage
       cid
       (Pong id')
@@ -92,30 +96,32 @@ handleMessage (TickUpdate !slice !wizard) = do
   put newState
 
 handleMessage x =
-  liftIO $ putStrLn $ "received unexpected message from server: " <> show x
+  logPrint Warning $ "received unexpected message from server: " <> show x
 
 -- Gracefully shut down the client with an error message
 gracefulExit
-  :: StateContainer
+  :: LogLevel
+  -> StateContainer
   -> String
   -> IO ()
-gracefulExit st reason = do
+gracefulExit curLevel st reason = do
-  liftIO $ putStrLn reason
+  logPrintIO curLevel Info reason
   writeIORef (scStopper st) True
 
 receiveMessage
-  :: Socket
+  :: LogLevel
+  -> Socket
   -> STM.TQueue ServerMessage
   -> StateContainer
   -> IO ()
-receiveMessage sock queue st = do
+receiveMessage curLevel sock queue st = do
   let maxBufferLength = 4096
   ptr <- mallocArray maxBufferLength
   ebufferLength <- try $ recvBuf sock ptr maxBufferLength
   -- putStrLn $ "received buffer of length: " <> show ebufferLength
   bufferLength <- case ebufferLength of
     Left (_ :: IOException) ->  do
-      gracefulExit st "Quitting due to connection loss"
+      gracefulExit curLevel st "Quitting due to connection loss"
       pure 0
     Right len -> pure len
   rawMsg <- B.pack <$> peekArray bufferLength ptr
@@ -129,7 +135,7 @@ receiveMessage sock queue st = do
     (\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
         )
@@ -147,8 +153,8 @@ terminateGameOnSigint stopper = do
   void $ liftIO $ installHandler
     keyboardSignal
     (CatchOnce $ do
-      putStrLn "receiveMessage: SIGINT caught, terminating…"
+      logPrintIO (rcLogLevel rc) Info "receiveMessage: SIGINT caught, terminating…"
-      liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc)
+      liftIO $ partingMessage (rcLogLevel rc) (rcClientUUID rc) (rcSocket rc)
       atomicWriteIORef stopper True
       -- Vty.shutdown (clientVty currentState)
       -- Raise SIGINT again so it does not get blocked
@@ -157,10 +163,11 @@ terminateGameOnSigint stopper = do
     Nothing
 
 partingMessage
-  :: UUID
+  :: LogLevel
+  -> UUID
   -> Socket
   -> IO ()
-partingMessage clientId sock = do
+partingMessage curLevel clientId sock = do
-  sendMessage (ClientMessage clientId ClientQuit) sock
+  sendMessage curLevel (ClientMessage clientId ClientQuit) sock
   putStrLn "sent parting message to server"
-  threadDelay (10 ^ 6)
+  threadDelay (10 ^ (6 :: Int))

src-client/Client/Events.hs

@@ -18,7 +18,8 @@ handleEvent
   -> Game ()
 handleEvent (EvKey KEsc _) = do
   st <- get
-  liftIO $ gracefulExit st "Quitting due to user input"
+  curLevel <- asks rcLogLevel
+  liftIO $ gracefulExit curLevel st "Quitting due to user input"
 handleEvent _ =
   pure ()
 

src-client/Client/Game.hs

@@ -15,6 +15,7 @@ import Data.IORef (readIORef)
 import Client.Communication
 import Client.Events
 import Client.Graphics
+import Client.Log (logPrint)
 import Client.Types
 
 import Library.Types
@@ -25,14 +26,15 @@ runGame = do
   sock <- asks rcSocket
   messageQueue <- asks rcMessageQueue
   clientId <- asks rcClientUUID
+  curLevel <- asks rcLogLevel
   st <- get
   vty <- clientVty <$> liftIO (atomically $ readTMVar (scClientState st))
-  liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
+  liftIO $ sendMessage curLevel (ClientMessage clientId ClientReady) sock
-  liftIO $ putStrLn "entering game loop"
+  logPrint Info "entering game loop"
   whileM_
     (liftIO (not <$> readIORef (scStopper st)))
     (do
-      liftIO $ receiveMessage sock messageQueue st
+      liftIO $ receiveMessage curLevel sock messageQueue st
       -- liftIO $ putStrLn "received messages"
       handleMessages
       -- liftIO $ putStrLn "handled messages"
@@ -43,7 +45,7 @@ runGame = do
       draw
       -- liftIO $ putStrLn "drew"
     )
+  logPrint Info "left game loop"
   liftIO $ do
-    liftIO $ putStrLn "left game loop"
+    partingMessage curLevel clientId sock
-    partingMessage clientId sock
+    threadDelay (10 ^ (6 :: Int))
-    threadDelay (10 ^ 6)

src-client/Client/Graphics.hs

@@ -14,8 +14,6 @@ import Graphics.Vty
 
 import Linear hiding (trace)
 
-import Debug.Trace
-
 -- internal imports
 
 import Client.Types

src-client/Client/Log.hs

@@ -0,0 +1,29 @@
+module Client.Log where
+
+import Control.Monad (when)
+
+import Control.Monad.RWS (asks, MonadIO (liftIO))
+
+import Debug.Trace (traceIO)
+
+-- internal imports
+
+import Client.Types (Game, LogLevel, ReaderContainer(rcLogLevel))
+
+logPrint
+  :: LogLevel
+  -> String
+  -> Game ()
+logPrint level msg = do
+  curLevel <- asks rcLogLevel
+  when (level <= curLevel) $
+    liftIO $ traceIO $ show level <> ": " <> msg
+
+logPrintIO
+  :: LogLevel
+  -> LogLevel
+  -> String
+  -> IO ()
+logPrintIO curLevel level msg = do
+  when (level <= curLevel) $
+    liftIO $ traceIO $ show level <> ": " <> msg

src-client/Client/Types.hs

@@ -21,22 +21,39 @@ import Options.Applicative as O
 
 import Library.Types
 
-newtype Options = Options
+data Options = Options
-  { optSockLoc :: FilePath
+  { optLogLevel :: LogLevel
+  , optSockLoc  :: FilePath
   }
 
 options :: O.Parser Options
 options = Options
-  <$> argument str
+  <$> option auto
+    ( metavar "LEVEL"
+    <> help "Log level (Error, Warning, Info or Verbose)"
+    <> long "log"
+    <> short 'l'
+    <> value Warning
+    )
+  <*> argument str
     ( metavar "FILEPATH"
     <> help "Location of the server's socket"
     )
 
+
+data LogLevel
+  = Error
+  | Warning
+  | Info
+  | Verbose
+  deriving (Eq, Ord, Show, Read)
+
 data ReaderContainer = ReaderContainer
   { rcSocket       :: Socket
   , rcClientUUID   :: UUID
   , rcMessageQueue :: STM.TQueue ServerMessage
   , rcEventQueue   :: STM.TQueue Event
+  , rcLogLevel     :: LogLevel
   }
 
 data StateContainer = StateContainer

src-client/Main.hs

@@ -23,6 +23,7 @@ import Options.Applicative
 
 import Client.Communication
 import Client.Game
+import Client.Log
 import Client.Types
 
 import Library.Types
@@ -30,10 +31,10 @@ import Library.Types
 main :: IO ()
 main = do
   putStrLn "Hello, Arena!"
-  (Options socketLocation) <- execParser opts
+  (Options logLevel socketLocation) <- execParser opts
-  putStrLn $ "connecting to Socket " <> socketLocation
+  logPrintIO Info logLevel $ "connecting to Socket " <> socketLocation
   sock <- connectSocket socketLocation
-  putStrLn "connected"
+  logPrintIO Info logLevel "connected"
 
 
   messageQueue <- STM.newTQueueIO
@@ -41,24 +42,31 @@ main = do
 
 
   -- threadDelay $ 1 * 10 ^ 6
-  mockClientState <- STM.newTMVarIO (ClientState undefined False)
+  mockClientState <- STM.newTMVarIO
-  let mockState = StateContainer undefined mockClientState undefined undefined
+    ( ClientState
-  sendMessage IdRequest sock
+      (error "trying to access vty of mock client state")
-  awaitResponse sock messageQueue mockState 0
+      False
-  clientIdMsg <- head <$> STM.atomically (STM.flushTQueue messageQueue)
+    )
+  let mockState =
+        StateContainer
+          (error "trying to access wizard of mock game state")
+          mockClientState
+          (error "trying to access map slice of mock game state")
+          (error "trying to access stop condition of mock game state")
+  sendMessage logLevel IdRequest sock
+  clientIdMsg <- awaitResponse logLevel sock messageQueue mockState 0
   let clientId = acClientUUID clientIdMsg
-  putStrLn $ "received client UUID: " <> show clientId
+  logPrintIO Info logLevel $ "received client UUID: " <> show clientId
 
 
   putStrLn welcomeText
-  threadDelay $ 5 * 10 ^ 6
+  threadDelay $ 5 * 10 ^ (6 :: Int)
 
 
-  sendMessage (ClientMessage clientId ClientRequestWizard) sock
+  sendMessage logLevel (ClientMessage clientId ClientRequestWizard) sock
   -- threadDelay $ 1 * 10 ^ 6
-  awaitResponse sock messageQueue mockState 1
+  playerWizard <- awaitResponse logLevel sock messageQueue mockState 1
-  playerWizard <- head <$> STM.atomically (STM.flushTQueue messageQueue)
+  logPrintIO Info logLevel $ "received wizard: " <> show (initWizard playerWizard)
-  putStrLn $ "received wizard: " <> show (initWizard playerWizard)
 
   vty <- mkVty defaultConfig
   hideCursor (outputIface vty)
@@ -69,24 +77,24 @@ main = do
   stopper <- newIORef False
   clientState <- STM.newTMVarIO (ClientState vty False)
   let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
-  let initRead = ReaderContainer sock clientId messageQueue eventQueue
+  let initRead = ReaderContainer sock clientId messageQueue eventQueue logLevel
       initState = StateContainer (initWizard playerWizard) clientState initSlice stopper
   -- putStrLn "sending quit message"
   -- sendMessage (ClientMessage clientId ClientQuit) sock
-  putStrLn "entering Game Monad"
+  logPrintIO Info logLevel "entering Game Monad"
   void $ execRWST
     (do
       terminateGameOnSigint stopper
-      liftIO $ putStrLn "entering main game function"
+      logPrint Verbose "entering main game function"
       runGame
     )
     initRead
     initState
-  putStrLn "Shutting down client…"
+  logPrintIO Info logLevel "Shutting down client…"
   showCursor (outputIface vty)
   shutdown vty
-  threadDelay (10 ^ 3)
+  threadDelay 1000
-  putStrLn "Closing connection to server…"
+  logPrintIO Info logLevel "Closing connection to server…"
   close sock
   putStrLn "bye bye"
   where
@@ -112,17 +120,18 @@ welcomeText = mconcat $ map (<> "\n")
   ]
 
 awaitResponse
-  :: Socket
+  :: LogLevel
+  -> Socket
   -> STM.TQueue ServerMessage
   -> StateContainer
   -> Int
-  -> IO ()
+  -> IO ServerMessage
-awaitResponsea _ _ _ 10 = error "Tries to communicate with server exceeded"
+awaitResponse _ _ _ _ 10 = error "Tries to communicate with server exceeded"
-awaitResponse sock messageQueue mockState numTries = do
+awaitResponse curLevel sock messageQueue mockState numTries = do
-  receiveMessage sock messageQueue mockState
+  receiveMessage curLevel sock messageQueue mockState
   responsePresent <- not <$> STM.atomically (STM.isEmptyTQueue messageQueue)
   if responsePresent
-  then pure ()
+  then STM.atomically $ STM.readTQueue messageQueue
   else do
-    threadDelay $ 10 ^ 6
+    threadDelay $ 10 ^ (6 :: Int)
-    awaitResponse sock messageQueue mockState (succ numTries)
+    awaitResponse curLevel sock messageQueue mockState (numTries + 1)

wizard-wipeout.cabal

@@ -40,6 +40,7 @@ executable wizard-wipeout-client
                       Client.Events
                       Client.Game
                       Client.Graphics
+                      Client.Log
                       Client.Types
     -- other-extensions:
     build-depends:    base >=4.17.2.1