From bbf60abc598215257b13714e9e50ea677764cb95 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 7 Nov 2024 17:47:11 +0100 Subject: [PATCH] make client logging sensible --- src-client/Client/Communication.hs | 49 ++++++++++++---------- src-client/Client/Events.hs | 3 +- src-client/Client/Game.hs | 14 ++++--- src-client/Client/Graphics.hs | 2 - src-client/Client/Log.hs | 29 +++++++++++++ src-client/Client/Types.hs | 23 +++++++++-- src-client/Main.hs | 65 +++++++++++++++++------------- wizard-wipeout.cabal | 1 + 8 files changed, 125 insertions(+), 61 deletions(-) create mode 100644 src-client/Client/Log.hs diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index fbfc374..be300ad 100644 --- a/src-client/Client/Communication.hs +++ b/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 - putStrLn $ "sending message: " <> show msg +sendMessage curLevel msg sock = do + 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 - putStrLn "Quitting due to server shutdown" + logPrint Info "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 - liftIO $ putStrLn reason +gracefulExit curLevel st reason = do + 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…" - liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc) + logPrintIO (rcLogLevel rc) Info "receiveMessage: SIGINT caught, terminating…" + 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 - sendMessage (ClientMessage clientId ClientQuit) sock +partingMessage curLevel clientId sock = do + sendMessage curLevel (ClientMessage clientId ClientQuit) sock putStrLn "sent parting message to server" - threadDelay (10 ^ 6) + threadDelay (10 ^ (6 :: Int)) diff --git a/src-client/Client/Events.hs b/src-client/Client/Events.hs index 110a72f..578105c 100644 --- a/src-client/Client/Events.hs +++ b/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 () diff --git a/src-client/Client/Game.hs b/src-client/Client/Game.hs index 788eda3..e60abf3 100644 --- a/src-client/Client/Game.hs +++ b/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 $ putStrLn "entering game loop" + liftIO $ sendMessage curLevel (ClientMessage clientId ClientReady) sock + 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 clientId sock - threadDelay (10 ^ 6) + partingMessage curLevel clientId sock + threadDelay (10 ^ (6 :: Int)) diff --git a/src-client/Client/Graphics.hs b/src-client/Client/Graphics.hs index c6089bd..c821cbb 100644 --- a/src-client/Client/Graphics.hs +++ b/src-client/Client/Graphics.hs @@ -14,8 +14,6 @@ import Graphics.Vty import Linear hiding (trace) -import Debug.Trace - -- internal imports import Client.Types diff --git a/src-client/Client/Log.hs b/src-client/Client/Log.hs new file mode 100644 index 0000000..3fd4547 --- /dev/null +++ b/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 diff --git a/src-client/Client/Types.hs b/src-client/Client/Types.hs index dadbfb0..5991623 100644 --- a/src-client/Client/Types.hs +++ b/src-client/Client/Types.hs @@ -21,22 +21,39 @@ import Options.Applicative as O import Library.Types -newtype Options = Options - { optSockLoc :: FilePath +data Options = Options + { 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 diff --git a/src-client/Main.hs b/src-client/Main.hs index 4b32f38..0b63ccd 100644 --- a/src-client/Main.hs +++ b/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 - putStrLn $ "connecting to Socket " <> socketLocation + (Options logLevel socketLocation) <- execParser opts + 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) - let mockState = StateContainer undefined mockClientState undefined undefined - sendMessage IdRequest sock - awaitResponse sock messageQueue mockState 0 - clientIdMsg <- head <$> STM.atomically (STM.flushTQueue messageQueue) + mockClientState <- STM.newTMVarIO + ( ClientState + (error "trying to access vty of mock client state") + False + ) + 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 <- head <$> STM.atomically (STM.flushTQueue messageQueue) - putStrLn $ "received wizard: " <> show (initWizard playerWizard) + playerWizard <- awaitResponse logLevel sock messageQueue mockState 1 + logPrintIO Info logLevel $ "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) - putStrLn "Closing connection to server…" + threadDelay 1000 + 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 () -awaitResponsea _ _ _ 10 = error "Tries to communicate with server exceeded" -awaitResponse sock messageQueue mockState numTries = do - receiveMessage sock messageQueue mockState + -> IO ServerMessage +awaitResponse _ _ _ _ 10 = error "Tries to communicate with server exceeded" +awaitResponse curLevel sock messageQueue mockState numTries = do + 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 - awaitResponse sock messageQueue mockState (succ numTries) + threadDelay $ 10 ^ (6 :: Int) + awaitResponse curLevel sock messageQueue mockState (numTries + 1) diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index b3d3c57..97bbd06 100644 --- a/wizard-wipeout.cabal +++ b/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