server mostly done, debugging and documentation missing

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)