tickLeisteServer/app/WebSocketApp.hs

{-# LANGUAGE OverloadedStrings #-}

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 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 (maybe)
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

----------------------------------------------------------------------------------
------------------------ 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)

newServerState :: ServerState
newServerState = M.empty

application :: MVar ServerState -> WS.ServerApp
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
      WS.rejectRequestWith pending WS.defaultRejectRequest
    else do
      conn <- WS.acceptRequest pending
      WS.withPingThread conn 30 (return ()) $ do
        clientUUID <- U.nextRandom
        bracket
          (addClient requestPath (clientUUID, conn) ssMV)
          (const $ removeClient requestPath (clientUUID, conn) ssMV)
          (clientLogic conn)

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, M.empty, [client], 1)
        sessionStateMVar <- newMVar sessionState
        let serverState' = M.insert sessionId sessionStateMVar serverState
        return (serverState', sessionStateMVar)
    )
    ( \sessionStateMVar -> do
        modifyMVar_ sessionStateMVar (\(tl, p, cls, sem) -> return (tl, p, client : cls, sem + 1))
        return (serverState, sessionStateMVar)
    )
    (serverState M.!? sessionId)

removeClient :: SessionId -> Client -> MVar ServerState -> IO ()
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"
        return serverState
    )
    ( \sessionStateMVar -> do
        modifyMVar sessionStateMVar $ \(tl, p, cls, sem) -> do
          let sem' = sem - 1
              removedClient = (tl, p, filter ((/= fst client) . fst) cls, sem')
          if sem' == 0
            then return (removedClient, sessionId `M.delete` serverState)
            else return (removedClient, serverState)
    )
    (serverState M.!? sessionId)