From 9bfddbabdc33c559d3b8aedc09cf31313fdfae60 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Fri, 9 Apr 2021 02:55:13 +0200 Subject: [PATCH] added logging to WebSocketApp --- app/WebSocketApp.hs | 64 +++++++++++++++++++++++++++++---------------- 1 file changed, 42 insertions(+), 22 deletions(-) diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs index a0434be..9021e72 100644 --- a/app/WebSocketApp.hs +++ b/app/WebSocketApp.hs @@ -8,19 +8,21 @@ import Control.Arrow (first, second) import UnliftIO.MVar import UnliftIO.Exception import Control.Monad.IO.Unlift -import Control.Monad -import Control.Monad.Reader.Class +import Control.Monad (foldM) +import Control.Monad.Reader.Class(ask) import Data.Aeson import qualified Data.Aeson.TickLeiste as TL import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as M import Data.Maybe (maybe) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.TickLeiste as TL import qualified Data.UUID as U import qualified Data.UUID.V4 as U import qualified Network.WebSockets as WS -import System.IO +import Colog.Message ---------------------------------------------------------------------------------- ------------------------ NEVER USE putMVar OR takeMVar --------------------------- @@ -50,6 +52,10 @@ type SessionState = (TL.TickLeiste, M.Map U.UUID T.Text, [Client], Integer) type ServerState = M.Map SessionId (MVar SessionState) +clientToText :: Client -> T.Text +clientToText = U.toText . fst +{-# INLINE clientToText #-} + newServerState :: ServerState newServerState = M.empty @@ -73,31 +79,35 @@ application' ssMV pending = do -- TODO reject Body should probably not empty... -- this may need a better logic liftIO $ WS.rejectRequestWith pending WS.defaultRejectRequest + logWarning "Rejected Client connection" else do conn <- liftIO $ WS.acceptRequest pending withPingThread conn 30 (return ()) $ do clientUUID <- liftIO U.nextRandom + let client = (clientUUID, conn) bracket - (addClient requestPath (clientUUID, conn) ssMV) + (addClient requestPath client ssMV) (const $ removeClient requestPath (clientUUID, conn) ssMV) - (clientLogic conn) + (\mvar -> clientLogic client mvar `catch` connectionExceptionHandler client) -clientLogic :: WS.Connection -> MVar SessionState -> EnvM () -clientLogic conn sessionStateMVar = do - msg <- (liftIO $ WS.receiveData conn :: EnvM B.ByteString) +connectionExceptionHandler :: Client -> WS.ConnectionException -> EnvM () +connectionExceptionHandler client WS.ConnectionClosed = logWarning $ "Client(" <> clientToText client <> ") connection died unexpectedly" +connectionExceptionHandler client (WS.CloseRequest w bs) = logInfo $ "Client(" <> clientToText client <> ") requsted to close the Connection with code: " <> T.pack (show w) <> " and reason: " <> T.decodeUtf8 (BL.toStrict bs) +connectionExceptionHandler client (WS.ParseException s) = logWarning $ "Client(" <> clientToText client <> ") send Garbage: " <> T.pack s +connectionExceptionHandler client (WS.UnicodeException s) = logWarning $ "Client(" <> clientToText client <> ") send invalid unicode: " <> T.pack s + +clientLogic :: Client -> MVar SessionState -> EnvM () +clientLogic client sessionStateMVar = do + msg <- (liftIO $ WS.receiveData (snd client) :: EnvM B.ByteString) maybe - ( do - --hPutStr stderr "Unable to parse JSON: " - --hPrint stderr msg - return () - ) + (logWarning $ "Client(" <> clientToText client <> ") send invalid JSON: " <> T.decodeUtf8 msg) -- the next line is a bit ugly, maybe there is a better way? -- maybe refactor, so that the request Handler can choose to lock or not. -- TODO - (\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler conn sessionState request)) + (\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler client sessionState request)) (decodeStrict msg :: Maybe TL.JSONRequest) - clientLogic conn sessionStateMVar + clientLogic client sessionStateMVar -requestHandler :: WS.Connection -> SessionState -> TL.JSONRequest -> EnvM SessionState +requestHandler :: Client -> SessionState -> TL.JSONRequest -> EnvM SessionState requestHandler conn (tl, pl, cls, sem) (TL.SetPlayerTickR playerUUID tick) = do let tl' = TL.setPlayerTick playerUUID tick tl broadcastEvent (TL.SetPlayerTickE playerUUID tick) cls @@ -133,10 +143,12 @@ requestHandler conn (tl, pl, cls, sem) (TL.RemovePlayerR playerUUID) = do return (tl', pl', cls, sem) broadcastEvent :: TL.JSONEvent -> [Client] -> EnvM () -broadcastEvent event = mapM_ $ sendClientEvent event . snd +broadcastEvent event = mapM_ $ sendClientEvent event -sendClientEvent :: TL.JSONEvent -> WS.Connection -> EnvM () -sendClientEvent event = liftIO . flip WS.sendTextData ( encode event) +sendClientEvent :: TL.JSONEvent -> Client -> EnvM () +sendClientEvent event client = do + liftIO $ WS.sendTextData (snd client) ( encode event) + logDebug $ "Send client: " <> clientToText client <> " Event: " <> (T.pack . show $ event) -- if you find something better than this ugly stuff ... feel free tickLeisteListToPlayerList :: M.Map U.UUID T.Text -> [(TL.Tick, [U.UUID])] -> [(TL.Tick, [(U.UUID, T.Text)])] @@ -169,6 +181,7 @@ playerNameListToTickLeisteList = unknownPlayerName :: T.Text unknownPlayerName = "Unknown Player" +-- TODO restructer such that we don't have the logic to add a player twice in this function addClient :: SessionId -> Client -> MVar ServerState -> EnvM (MVar SessionState) addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState -> maybe @@ -176,10 +189,13 @@ addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serve let sessionState = (TL.newTickLeiste, M.empty, [client], 1) sessionStateMVar <- newMVar sessionState let serverState' = M.insert sessionId sessionStateMVar serverState + logDebug $ "Added TickLeiste: " <> (T.pack . show $ sessionId) + logInfo $ "Added Client: " <> clientToText client <> " to TickLeiste: " <> (T.pack . show) sessionId return (serverState', sessionStateMVar) ) ( \sessionStateMVar -> do modifyMVar_ sessionStateMVar (\(tl, p, cls, sem) -> return (tl, p, client : cls, sem + 1)) + logInfo $ "Added Client: " <> clientToText client <> " to TickLeiste " <> (T.pack . show) sessionId return (serverState, sessionStateMVar) ) (serverState M.!? sessionId) @@ -188,15 +204,19 @@ removeClient :: SessionId -> Client -> MVar ServerState -> EnvM () removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState -> maybe ( do - --hPutStrLn stderr "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG" + logError "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG" return serverState ) ( \sessionStateMVar -> do modifyMVar sessionStateMVar $ \(tl, p, cls, sem) -> do let sem' = sem - 1 removedClient = (tl, p, filter ((/= fst client) . fst) cls, sem') + logDebug $ "Removed Client: " <> clientToText client <> " from TickLeist " <> (T.pack . show) sessionId if sem' == 0 - then return (removedClient, sessionId `M.delete` serverState) - else return (removedClient, serverState) + then do + logDebug $ "Removed TickLeiste: " <> (T.pack . show) sessionId + return (removedClient, sessionId `M.delete` serverState) + + else return (removedClient, serverState) ) (serverState M.!? sessionId)