222 lines
10 KiB
Haskell
222 lines
10 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module WebSocketApp (newServerState, ServerState, application) where
|
|
|
|
import Environment
|
|
import Control.Monad.IO.Class
|
|
import Control.Arrow (first, second)
|
|
import UnliftIO.MVar
|
|
import UnliftIO.Exception
|
|
import Control.Monad.IO.Unlift
|
|
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 Colog.Message
|
|
|
|
----------------------------------------------------------------------------------
|
|
------------------------ NEVER USE putMVar OR takeMVar ---------------------------
|
|
----------------------------------------------------------------------------------
|
|
|
|
-- if use ask yourself why this warning above me exists, this code relies upon the
|
|
-- atomicity of modifyMVar, which is only the case if no one produces MVar. It is
|
|
-- realy easy to archive this using putMVar. So not using it will make reasoning
|
|
-- about the code much simpler. takeMVar on the other hand may produce deadlocks
|
|
-- as an MVar is gone and nobody will produce a new one.
|
|
-- putMVar and takeMVar are not evil in general, but it contradicts the way this
|
|
-- code uses MVar to synchronize.
|
|
-- In theory you could write fine code using them, but then you need to make sure
|
|
-- to use them as a pair and mask yourself from asynchronous exceptions. But
|
|
-- that is basically a reimplementation of modifyMVar
|
|
|
|
-- maybe this should be T.Text instead, but right now I try
|
|
-- to get away without the need of parsing the request Path
|
|
-- in any way. If we need, then we should probably change this to T.Text
|
|
type SessionId = B.ByteString
|
|
|
|
-- we only use the uuids here, because 'WS.WS.Connection' has no Eq, and we need
|
|
-- to delete clients
|
|
type Client = (U.UUID, WS.Connection)
|
|
|
|
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
|
|
|
|
-- shift the PendingConnection parameter outside of EnvM
|
|
application :: MVar ServerState -> EnvM WS.ServerApp
|
|
application mvar = do
|
|
r <- ask
|
|
return (runEnvM r . application' mvar)
|
|
|
|
|
|
-- Unlifted WS.withPingThread
|
|
withPingThread :: WS.Connection -> Int -> EnvM () -> EnvM a -> EnvM a
|
|
withPingThread conn int rep action = withRunInIO $ \run -> WS.withPingThread conn int (run rep) (run action)
|
|
|
|
application' :: MVar ServerState -> WS.PendingConnection -> EnvM ()
|
|
application' 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
|
|
then 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 client ssMV)
|
|
(const $ removeClient requestPath (clientUUID, conn) ssMV)
|
|
(\mvar -> clientLogic client mvar `catch` connectionExceptionHandler client)
|
|
|
|
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
|
|
(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 client sessionState request))
|
|
(decodeStrict msg :: Maybe TL.JSONRequest)
|
|
clientLogic client sessionStateMVar
|
|
|
|
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
|
|
return (tl', pl, cls, sem)
|
|
requestHandler conn (tl, pl, cls, sem) (TL.AddPlayerTickR playerName tick) = do
|
|
playerUUID <- liftIO U.nextRandom
|
|
let tl' = TL.setPlayerTick playerUUID tick tl
|
|
pl' = M.insert playerUUID playerName pl
|
|
broadcastEvent (TL.AddPlayerTickE playerUUID playerName tick) cls
|
|
return (tl', pl', cls, sem)
|
|
-- Mayeb this is more efficient if we don't convert back and forth, but the UUID must be
|
|
-- added regardless
|
|
requestHandler conn (tl, pl, cls, sem) (TL.InitializeTickLeisteR preTickLeiste) = do
|
|
(tl', pl') <- playerNameListToTickLeisteList preTickLeiste
|
|
let tll = tickLeisteListToPlayerList pl tl'
|
|
broadcastEvent (TL.InitializeTickLeisteE tll) cls
|
|
return (TL.fromList tl', pl', cls, sem)
|
|
|
|
-- TODO
|
|
-- Also TickLeisteR must be inside the modifyMVar, because we use the MVar also as a lock, and we can't
|
|
-- have changes between reading the TickLeiste and sending the information.
|
|
requestHandler conn ss@(tl, pl, cls, sem) TL.TickLeisteR = do
|
|
sendClientEvent (TL.InitializeTickLeisteE $ tickLeisteToPlayerList pl tl) conn
|
|
return ss
|
|
requestHandler conn (tl, pl, cls, sem) (TL.ChangeNameR playerUUID playerName) = do
|
|
let pl' = M.insert playerUUID playerName pl
|
|
broadcastEvent (TL.ChangeNameE playerUUID playerName) cls
|
|
return (tl, pl', cls, sem)
|
|
requestHandler conn (tl, pl, cls, sem) (TL.RemovePlayerR playerUUID) = do
|
|
let tl' = TL.removePlayer playerUUID tl
|
|
pl' = M.delete playerUUID pl
|
|
broadcastEvent (TL.RemovePlayerE playerUUID) cls
|
|
return (tl', pl', cls, sem)
|
|
|
|
broadcastEvent :: TL.JSONEvent -> [Client] -> EnvM ()
|
|
broadcastEvent event = mapM_ $ sendClientEvent 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)])]
|
|
tickLeisteListToPlayerList pl = fmap (second (fmap (\uuid -> maybe (uuid, unknownPlayerName) (\name -> (uuid, name)) (pl M.!? uuid))))
|
|
|
|
tickLeisteToPlayerList :: M.Map U.UUID T.Text -> TL.TickLeiste -> [(TL.Tick, [(U.UUID, T.Text)])]
|
|
tickLeisteToPlayerList pl = tickLeisteListToPlayerList pl . TL.toList
|
|
|
|
-- uff good luck reading that
|
|
-- maybe it would be better to collect the UUID to Text map in a list and call M.fromList in the end?
|
|
playerNameListToTickLeisteList :: [(TL.Tick, [T.Text])] -> EnvM ([(TL.Tick, [U.UUID])], M.Map U.UUID T.Text)
|
|
playerNameListToTickLeisteList =
|
|
foldM
|
|
( \(tl, pl) (tick, plns) -> do
|
|
(tl', pl') <-
|
|
foldM
|
|
( \(tl, pl) playerName -> do
|
|
playerUUID <- liftIO U.nextRandom
|
|
let tl' = playerUUID : tl
|
|
pl' = M.insert playerUUID playerName pl
|
|
return (tl', pl')
|
|
)
|
|
([] :: [U.UUID], pl)
|
|
(reverse plns)
|
|
return ((tick, tl') : tl, pl')
|
|
)
|
|
([] :: [(TL.Tick, [U.UUID])], M.empty)
|
|
. reverse
|
|
|
|
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
|
|
( do
|
|
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)
|
|
|
|
removeClient :: SessionId -> Client -> MVar ServerState -> EnvM ()
|
|
removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState ->
|
|
maybe
|
|
( do
|
|
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 do
|
|
logDebug $ "Removed TickLeiste: " <> (T.pack . show) sessionId
|
|
return (removedClient, sessionId `M.delete` serverState)
|
|
|
|
else return (removedClient, serverState)
|
|
)
|
|
(serverState M.!? sessionId)
|