Splittertech/tickLeisteServer
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

started logging (but it's a bit ugly)

Browse source
This commit is contained in:
Dennis Frieberg 2020-10-06 13:03:36 +02:00
parent 04d9f063d4
commit 56e546f5dd
6 changed files with 55 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

27
app/WebSocketApp.hs
View file

@ -11,14 +11,18 @@ import Data.Aeson
import qualified Data.Aeson.TickLeiste as TL
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import Data.Maybe (maybe)
import Data.Maybe (maybe) -- should be replaced by either
import Data.Either (either)
import qualified Data.Text 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 Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Colog as Log hiding (logError,logWarning,logInfo,logDebug)
import qualified Logging as Log
----------------------------------------------------------------------------------
------------------------ NEVER USE putMVar OR takeMVar ---------------------------
----------------------------------------------------------------------------------
@ -50,8 +54,8 @@ type ServerState = M.Map SessionId (MVar SessionState)
newServerState :: ServerState
newServerState = M.empty
application :: MVar ServerState -> WS.ServerApp
application ssMV pending = do
application :: Log.LogAction IO Log.Message -> MVar ServerState -> WS.ServerApp
application logAction ssMV pending = do
-- maybe we want to check that the Path has a maximum length or something
let requestPath = WS.requestPath $ WS.pendingRequest pending
if B.null requestPath
@ -66,20 +70,19 @@ application ssMV pending = do
bracket
(addClient requestPath (clientUUID, conn) ssMV)
(const $ removeClient requestPath (clientUUID, conn) ssMV)
(clientLogic conn)
(clientLogic logAction conn)
clientLogic :: WS.Connection -> MVar SessionState -> IO ()
clientLogic conn sessionStateMVar = do
clientLogic :: Log.LogAction IO Log.Message -> WS.Connection -> MVar SessionState -> IO ()
clientLogic logAction conn sessionStateMVar = do
msg <- (WS.receiveData conn :: IO B.ByteString)
maybe
( do
hPutStr stderr "Unable to parse JSON: "
hPrint stderr msg
either
( \fmsg -> do
Log.logError logAction $ T.pack fmsg
)
-- the next line is a bit ugly, maybe there is a better way?
(\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler conn sessionState request))
(decodeStrict msg :: Maybe TL.JSONRequest)
clientLogic conn sessionStateMVar
(eitherDecodeStrict msg :: Either String TL.JSONRequest)
clientLogic logAction conn sessionStateMVar
requestHandler :: WS.Connection -> SessionState -> TL.JSONRequest -> IO SessionState
requestHandler conn (tl, pl, cls, sem) (TL.SetPlayerTickR playerUUID tick) = do