added logging to WebSocketApp
This commit is contained in:
Dennis Frieberg
parent
365bf7ea6e
commit
9bfddbabdc
1 changed files with 42 additions and 22 deletions
|
|
@ -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)
|
||||
then do
|
||||
logDebug $ "Removed TickLeiste: " <> (T.pack . show) sessionId
|
||||
return (removedClient, sessionId `M.delete` serverState)
|
||||
|
||||
else return (removedClient, serverState)
|
||||
)
|
||||
(serverState M.!? sessionId)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue