added logging to WebSocketApp

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 (foldM)
-import Control.Monad.Reader.Class
+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 ()
+connectionExceptionHandler :: Client -> WS.ConnectionException -> EnvM ()
-clientLogic conn sessionStateMVar = do
+connectionExceptionHandler client WS.ConnectionClosed = logWarning $ "Client(" <> clientToText client <> ") connection died unexpectedly"
-  msg <- (liftIO $ WS.receiveData conn :: EnvM B.ByteString)
+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
+    (logWarning $ "Client(" <> clientToText client <> ") send invalid JSON: " <> T.decodeUtf8 msg)
-        --hPutStr stderr "Unable to parse JSON: "
-        --hPrint stderr msg
-        return ()
-    )
     -- 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 :: TL.JSONEvent -> Client -> EnvM ()
-sendClientEvent event = liftIO . flip WS.sendTextData ( encode event)
+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)
+            then do
-            else return (removedClient, serverState)
+              logDebug $ "Removed TickLeiste: " <> (T.pack . show) sessionId
+              return (removedClient, sessionId `M.delete` serverState)
+
+          else return (removedClient, serverState)
     )
     (serverState M.!? sessionId)