wizard-wipeout/src-server/Server/Communication/Handler.hs
2024-05-01 23:52:49 +02:00

131 lines
4.5 KiB
Haskell

module Server.Communication.Handler where
import qualified Control.Concurrent.STM as STM
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Time
import Data.UUID.V4
import Library.Types
import Server.Communication.Send
import Server.Types
import Server.Util
-- | function for translating 'ClientMessage's into server actions
handleMessage
:: StateContainer
-> ReaderContainer
-> ClientMessage
-> IO ()
handleMessage stateContainer readerContainer msg = do
let clientList = scClientSockets stateContainer
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
-- putStrLn $ "Handling: " <> show msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (isNothing . ccUUID) clients
clientSock = ccSocket $ clients !! fromJust clientIdx
newClients = map
(\old@(ClientComms mUUID oldClientSock _) ->
if oldClientSock == clientSock && isNothing mUUID
then
old
{ ccUUID = Just clientId
}
else
old
)
clients
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
putStrLn $ "Accepted Client with UUID " <> show clientId
sendMessage (AcceptClient clientId) clientId clientList
ClientMessage clientId payload ->
case payload of
ClientQuit -> do
putStrLn $ "client " <> show clientId <> " has quit the game"
let client = find (\a -> ccUUID a == Just clientId) clients
dropClient clientList (ccSocket $ fromJust client)
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
now <- liftIO getCurrentTime
uuid <- nextRandom
let freshWizard = newWizard initPos
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
void $ STM.swapTMVar (scPlayers stateContainer) $
Player clientId freshWizard False (now, uuid) : currentPlayers
sendMessage (ProvideInitialWizard freshWizard) clientId clientList
ClientReady -> do
putStrLn $ "client " <> show clientId <> " is ready!"
now <- getCurrentTime
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
let (thisPlayers, otherPlayers) =
partition (\p -> playerId p == clientId) currentPlayers
unless (null thisPlayers) $
void $ STM.swapTMVar (scPlayers stateContainer) $
(head thisPlayers)
{ playerReady = True
, playerLastPong = (now, snd (playerLastPong $ head thisPlayers))
}
: otherPlayers
Pong uuid -> do
let mclient = find (\c -> ccUUID c == Just clientId) clients
maybe
(putStrLn $ "Who is " <> show uuid <> "?")
(\_ -> do
mPlayer <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer)
pure $ find (\p -> playerId p == clientId) players
maybe
(pure ())
(\player ->
if snd (playerLastPong player) /= uuid
then
putStrLn $ "Pong ID mismatch from " <> show clientId
else do
now <- getCurrentTime
STM.atomically$ do
players <- STM.readTMVar (scPlayers stateContainer)
let otherPlayers = filter (\a -> playerId a /= playerId player) players
modPlayer = player
{ playerLastPong = (now, uuid)
}
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
)
mPlayer
)
mclient
-- | handle received messages
handleMessages :: Game ()
handleMessages = do
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
liftIO $ do
msgs <- STM.atomically $ do
emptyState <- STM.isEmptyTQueue queue
if emptyState
then
pure []
else
STM.flushTQueue queue
void $ do
mapM_
(handleMessage serverState readerContainer)
msgs