nek0/wizard-wipeout
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

make client logging sensible

Browse source
This commit is contained in:
nek0 2024-11-07 17:47:11 +01:00
parent 892333bb6e
commit bbf60abc59
8 changed files with 125 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
src-client/Client/Communication.hs
View file

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

3
src-client/Client/Events.hs
View file

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

14
src-client/Client/Game.hs
View file

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

2
src-client/Client/Graphics.hs
View file

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

29
src-client/Client/Log.hs Normal file
View file

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

23
src-client/Client/Types.hs
View file

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

65
src-client/Main.hs
View file

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

1
wizard-wipeout.cabal
View file

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