diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs index 7eb8fa7..35d571b 100644 --- a/app/WebSocketApp.hs +++ b/app/WebSocketApp.hs @@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -module WebSocketApp (newServerState, ServerState) where +module WebSocketApp (newServerState, ServerState, application) where -- Maybe strict MVar?? but then we need NFData instenaces for TickLeiste +import Control.Arrow (first, second) import Control.Concurrent.MVar import Control.Exception -import Data.Aeson.TickLeiste +import Control.Monad +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 +import Data.Maybe (maybe) import qualified Data.Text as T import qualified Data.TickLeiste as TL import qualified Data.UUID as U @@ -40,7 +43,7 @@ type SessionId = B.ByteString -- to delete clients type Client = (U.UUID, WS.Connection) -type SessionState = (TL.TickLeiste, [Client], Integer) +type SessionState = (TL.TickLeiste, M.Map U.UUID T.Text, [Client], Integer) type ServerState = M.Map SessionId (MVar SessionState) @@ -63,22 +66,103 @@ application ssMV pending = do bracket (addClient requestPath (clientUUID, conn) ssMV) (const $ removeClient requestPath (clientUUID, conn) ssMV) - (eventHandler conn) + (clientLogic conn) -eventHandler :: WS.Connection -> MVar SessionState -> IO () -eventHandler = undefined +clientLogic :: WS.Connection -> MVar SessionState -> IO () +clientLogic conn sessionStateMVar = do + msg <- (WS.receiveData conn :: IO B.ByteString) + maybe + ( do + hPutStr stderr "Unable to parse JSON: " + hPrint stderr msg + ) + -- 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 + +requestHandler :: WS.Connection -> SessionState -> TL.JSONRequest -> IO 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 <- 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 it. +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] -> IO () +broadcastEvent event = mapM_ $ sendClientEvent event . snd + +sendClientEvent :: TL.JSONEvent -> WS.Connection -> IO () +sendClientEvent event = flip WS.sendTextData $ encode 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 +playerNameListToTickLeisteList :: [(TL.Tick, [T.Text])] -> IO ([(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 <- 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" addClient :: SessionId -> Client -> MVar ServerState -> IO (MVar SessionState) addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState -> maybe ( do - let sessionState = (TL.newTickLeiste, [client], 1) + let sessionState = (TL.newTickLeiste, M.empty, [client], 1) sessionStateMVar <- newMVar sessionState let serverState' = M.insert sessionId sessionStateMVar serverState return (serverState', sessionStateMVar) ) ( \sessionStateMVar -> do - modifyMVar_ sessionStateMVar (\(tl, cls, sem) -> return (tl, client : cls, sem + 1)) + modifyMVar_ sessionStateMVar (\(tl, p, cls, sem) -> return (tl, p, client : cls, sem + 1)) return (serverState, sessionStateMVar) ) (serverState M.!? sessionId) @@ -91,12 +175,11 @@ removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \s return serverState ) ( \sessionStateMVar -> do - modifyMVar sessionStateMVar $ \(tl, cls, sem) -> do + modifyMVar sessionStateMVar $ \(tl, p, cls, sem) -> do let sem' = sem - 1 - removedClient = (tl, filter ((/= fst client) . fst) cls, sem') - if sem - 1 == 0 + removedClient = (tl, p, filter ((/= fst client) . fst) cls, sem') + if sem' == 0 then return (removedClient, sessionId `M.delete` serverState) - else do - return (removedClient, serverState) + else return (removedClient, serverState) ) (serverState M.!? sessionId)