131 lines
4.5 KiB
Haskell
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
|