125 lines
4.4 KiB
Haskell
125 lines
4.4 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
|
|
queueMessage (AcceptClient clientId) clientId clientList
|
|
ClientMessage clientId payload ->
|
|
case payload of
|
|
ClientQuit -> do
|
|
putStrLn $ "client has quit the game: " <> show clientId
|
|
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
|
|
queueMessage (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)
|
|
sendUpdate stateContainer (rcMap readerContainer) player
|
|
)
|
|
mPlayer
|
|
)
|
|
mclient
|
|
|
|
-- | handle received messages
|
|
handleMessages :: Game ()
|
|
handleMessages = do
|
|
queue <- gets scMessageQueue
|
|
serverState <- get
|
|
readerContainer <- ask
|
|
liftIO $ do
|
|
msgs <- STM.atomically $
|
|
STM.flushTQueue queue
|
|
mapM_
|
|
(handleMessage serverState readerContainer)
|
|
msgs
|