2023-12-10 01:02:09 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2023-12-13 10:06:45 +00:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2023-12-09 12:58:59 +00:00
|
|
|
module Server.Communication where
|
|
|
|
|
2023-12-10 05:57:48 +00:00
|
|
|
import Control.Concurrent
|
|
|
|
|
|
|
|
import qualified Control.Concurrent.STM as STM
|
|
|
|
|
2023-12-09 12:58:59 +00:00
|
|
|
import Control.Monad
|
|
|
|
|
2023-12-10 01:02:09 +00:00
|
|
|
import Control.Monad.IO.Class
|
|
|
|
|
|
|
|
import Control.Monad.RWS.Strict
|
|
|
|
|
2023-12-10 16:00:50 +00:00
|
|
|
import qualified Data.Aeson as A
|
|
|
|
|
|
|
|
import qualified Data.ByteString as B
|
2023-12-11 06:07:09 +00:00
|
|
|
import qualified Data.ByteString.Lazy.Char8 as B8
|
2023-12-10 16:00:50 +00:00
|
|
|
|
2023-12-11 08:49:24 +00:00
|
|
|
import Data.List
|
|
|
|
|
2023-12-11 12:47:27 +00:00
|
|
|
import qualified Data.Matrix as M
|
|
|
|
|
2023-12-11 08:49:24 +00:00
|
|
|
import Data.Maybe
|
|
|
|
|
2023-12-23 10:38:57 +00:00
|
|
|
import Data.UUID hiding (null)
|
2023-12-10 16:00:50 +00:00
|
|
|
import Data.UUID.V4
|
|
|
|
|
2024-02-02 07:16:28 +00:00
|
|
|
import Data.Time
|
|
|
|
|
2023-12-11 06:07:09 +00:00
|
|
|
import qualified Data.Vector.Storable as VS
|
|
|
|
|
|
|
|
import Foreign hiding (void)
|
|
|
|
|
2023-12-11 12:47:27 +00:00
|
|
|
import Linear
|
|
|
|
|
2023-12-10 01:02:09 +00:00
|
|
|
import Network.Socket as Net
|
|
|
|
|
2023-12-09 12:58:59 +00:00
|
|
|
import System.Posix.Signals
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
2023-12-10 16:00:50 +00:00
|
|
|
import Library.Types
|
|
|
|
|
2023-12-10 01:02:09 +00:00
|
|
|
import Server.Types
|
2023-12-09 12:58:59 +00:00
|
|
|
import Server.Util
|
|
|
|
|
2023-12-09 13:18:10 +00:00
|
|
|
-- | Function which determines whether the given filePath is a supported socket path and
|
|
|
|
-- subsequently creates a socket in said location.
|
|
|
|
bindSocket
|
|
|
|
:: FilePath -- ^ File Path for socket to be created (e.g.: "/tmp/wizard.sock")
|
|
|
|
-> IO Socket -- ^ resulting Socket
|
2023-12-09 12:58:59 +00:00
|
|
|
bindSocket path = do
|
|
|
|
let sockAddr = SockAddrUnix path
|
|
|
|
unless (isSupportedSockAddr sockAddr)
|
|
|
|
(error $ "invalid socket path " <> path)
|
2023-12-09 13:18:10 +00:00
|
|
|
-- aremoveIfExists path
|
2023-12-10 01:02:09 +00:00
|
|
|
sock <- socket AF_UNIX Stream defaultProtocol
|
2023-12-09 12:58:59 +00:00
|
|
|
bind sock sockAddr
|
2023-12-10 01:02:09 +00:00
|
|
|
Net.listen sock 5
|
2023-12-09 12:58:59 +00:00
|
|
|
pure sock
|
|
|
|
|
2023-12-10 05:57:48 +00:00
|
|
|
-- | Function that installs a handler on SIGINT to terminate game
|
|
|
|
terminateGameOnSigint
|
2023-12-12 10:21:25 +00:00
|
|
|
:: FilePath
|
|
|
|
-> Game ()
|
|
|
|
terminateGameOnSigint path = do
|
2023-12-10 05:57:48 +00:00
|
|
|
sock <- asks rcMainSocket
|
|
|
|
clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
|
|
|
|
serverState <- gets scServerState
|
|
|
|
void $ liftIO $ installHandler
|
2023-12-12 10:21:25 +00:00
|
|
|
sigINT
|
2023-12-09 12:58:59 +00:00
|
|
|
(CatchOnce $ do
|
2023-12-12 10:21:25 +00:00
|
|
|
putStrLn "SIGINT caught, terminating…"
|
2023-12-10 05:57:48 +00:00
|
|
|
disconnectClients clients
|
2023-12-10 19:12:53 +00:00
|
|
|
close sock
|
2023-12-09 12:58:59 +00:00
|
|
|
removeIfExists path
|
2023-12-20 07:12:22 +00:00
|
|
|
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
|
2023-12-09 13:11:37 +00:00
|
|
|
-- Raise SIGINT again so it does not get blocked
|
2023-12-13 14:09:27 +00:00
|
|
|
-- raiseSignal sigINT
|
2023-12-09 12:58:59 +00:00
|
|
|
)
|
2023-12-12 12:44:33 +00:00
|
|
|
Nothing
|
2024-02-02 07:16:28 +00:00
|
|
|
|
|
|
|
disconnectClients
|
2024-02-02 08:07:11 +00:00
|
|
|
:: [(Maybe UUID, Socket)]
|
2024-02-02 07:16:28 +00:00
|
|
|
-> IO ()
|
|
|
|
disconnectClients = mapM_
|
|
|
|
(\(_, clientSocket) -> do
|
|
|
|
sendMessage ServerQuit clientSocket
|
|
|
|
close clientSocket
|
|
|
|
)
|
2023-12-10 01:02:09 +00:00
|
|
|
|
2024-02-02 14:50:57 +00:00
|
|
|
timeoutClients
|
|
|
|
:: [(Maybe UUID, Socket)]
|
|
|
|
-> IO ()
|
|
|
|
timeoutClients = mapM_
|
|
|
|
(\(_, clientSocket) -> do
|
|
|
|
close clientSocket
|
|
|
|
)
|
|
|
|
|
2023-12-10 01:02:09 +00:00
|
|
|
-- | Process incoming connection requests
|
2023-12-10 05:57:48 +00:00
|
|
|
processRequests :: Game ()
|
2023-12-10 01:02:09 +00:00
|
|
|
processRequests = do
|
|
|
|
mainSocket <- asks rcMainSocket
|
2023-12-10 05:57:48 +00:00
|
|
|
socketList <- gets scClientSockets
|
2023-12-10 08:53:56 +00:00
|
|
|
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
|
2023-12-10 05:57:48 +00:00
|
|
|
where
|
2023-12-10 08:53:56 +00:00
|
|
|
acceptConnection mainSocket socketList = do
|
2023-12-10 19:12:53 +00:00
|
|
|
putStrLn "accepting new connections…"
|
2023-12-10 08:53:56 +00:00
|
|
|
(clientSock, _) <- accept mainSocket
|
|
|
|
liftIO $ STM.atomically $ do
|
|
|
|
list <- STM.takeTMVar socketList
|
2023-12-11 08:49:24 +00:00
|
|
|
STM.putTMVar socketList ((Nothing, clientSock) : list)
|
|
|
|
putStrLn "accepted new connection"
|
2023-12-10 08:53:56 +00:00
|
|
|
acceptConnection mainSocket socketList
|
2023-12-10 01:02:09 +00:00
|
|
|
|
2023-12-10 16:00:50 +00:00
|
|
|
-- | Sends a specified message through given socket to the client
|
|
|
|
sendMessage
|
|
|
|
:: ServerMessage
|
|
|
|
-> Socket
|
|
|
|
-> IO ()
|
|
|
|
sendMessage msg sock = do
|
|
|
|
let msgJson = A.encode msg
|
2023-12-23 10:38:57 +00:00
|
|
|
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
|
2023-12-20 07:12:22 +00:00
|
|
|
-- putStrLn $ "sending: " <> B8.unpack msgJson
|
2023-12-11 06:07:09 +00:00
|
|
|
VS.unsafeWith
|
|
|
|
msgVector
|
|
|
|
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
|
2023-12-10 16:00:50 +00:00
|
|
|
|
2023-12-12 02:31:57 +00:00
|
|
|
-- | receive incoming messages from clients
|
2023-12-20 08:04:50 +00:00
|
|
|
receiveMessages
|
|
|
|
:: STM.TMVar [(Maybe UUID, Socket)]
|
|
|
|
-> STM.TQueue ClientMessage
|
|
|
|
-> IO ()
|
|
|
|
receiveMessages clientsVar queue = do
|
2023-12-10 08:53:56 +00:00
|
|
|
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
|
2023-12-20 08:04:50 +00:00
|
|
|
mapM_
|
2023-12-12 02:31:57 +00:00
|
|
|
(\(_, clientSocket) -> do
|
2023-12-11 09:48:25 +00:00
|
|
|
receiveMessage clientSocket queue
|
2023-12-10 01:02:09 +00:00
|
|
|
)
|
2023-12-10 05:57:48 +00:00
|
|
|
clients
|
2023-12-10 19:12:53 +00:00
|
|
|
|
2023-12-12 02:31:57 +00:00
|
|
|
-- | handle received messages
|
|
|
|
handleMessages :: Game ()
|
|
|
|
handleMessages = do
|
|
|
|
queue <- gets scMessageQueue
|
|
|
|
serverState <- get
|
|
|
|
readerContainer <- ask
|
|
|
|
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
|
|
|
|
void $ liftIO $ do
|
|
|
|
mapM_
|
|
|
|
(handleMessage serverState readerContainer)
|
|
|
|
msgs
|
|
|
|
|
2023-12-11 06:07:09 +00:00
|
|
|
-- | receive a 'ClientMessage'
|
2023-12-10 19:12:53 +00:00
|
|
|
receiveMessage
|
|
|
|
:: Socket
|
2023-12-11 09:48:25 +00:00
|
|
|
-> STM.TQueue ClientMessage
|
|
|
|
-> IO ()
|
|
|
|
receiveMessage sock queue = do
|
2023-12-11 06:07:09 +00:00
|
|
|
let maxBufferLength = 4096
|
2023-12-11 09:48:25 +00:00
|
|
|
mmsg <- do
|
2023-12-11 08:49:24 +00:00
|
|
|
ptr <- mallocArray maxBufferLength
|
|
|
|
bufferLength <- recvBuf sock ptr maxBufferLength
|
2023-12-11 06:07:09 +00:00
|
|
|
msg <- B.pack <$> peekArray bufferLength ptr
|
2023-12-11 08:49:24 +00:00
|
|
|
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
|
2023-12-11 06:07:09 +00:00
|
|
|
free ptr
|
2023-12-11 08:49:24 +00:00
|
|
|
if bufferLength > 0
|
|
|
|
then
|
|
|
|
pure mJsonMsg
|
|
|
|
else
|
|
|
|
pure Nothing
|
|
|
|
maybe
|
|
|
|
(pure ())
|
|
|
|
(\msg -> do
|
|
|
|
liftIO $ STM.atomically $ STM.writeTQueue queue msg
|
2023-12-20 08:04:50 +00:00
|
|
|
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
|
2023-12-11 08:49:24 +00:00
|
|
|
)
|
|
|
|
mmsg
|
|
|
|
|
|
|
|
-- | function for translating 'ClientMessage's into server actions
|
|
|
|
handleMessage
|
2023-12-11 12:47:27 +00:00
|
|
|
:: StateContainer
|
|
|
|
-> ReaderContainer
|
2023-12-12 01:53:05 +00:00
|
|
|
-> ClientMessage
|
2023-12-11 09:48:25 +00:00
|
|
|
-> IO ()
|
2023-12-12 01:53:05 +00:00
|
|
|
handleMessage stateContainer readerContainer msg = do
|
|
|
|
let clientList = scClientSockets stateContainer
|
2023-12-11 08:49:24 +00:00
|
|
|
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
|
2023-12-12 01:53:05 +00:00
|
|
|
putStrLn $ "Handling following: " <> show msg
|
|
|
|
case msg of
|
|
|
|
IdRequest -> do
|
|
|
|
clientId <- nextRandom
|
2024-02-02 07:16:28 +00:00
|
|
|
let clientIdx = findIndex (isNothing . fst) clients
|
2023-12-12 01:53:05 +00:00
|
|
|
let clientSock = snd $ clients !! fromJust clientIdx
|
|
|
|
let newClients = map
|
|
|
|
(\old@(muuid, oldClientSock) ->
|
2024-02-02 07:16:28 +00:00
|
|
|
if oldClientSock == clientSock && isNothing muuid
|
2023-12-12 01:53:05 +00:00
|
|
|
then
|
|
|
|
(Just clientId, clientSock)
|
|
|
|
else
|
|
|
|
old
|
|
|
|
)
|
|
|
|
clients
|
|
|
|
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
|
|
|
|
putStrLn $ "Accepted Client with UUID " <> show clientId
|
|
|
|
sendMessage (AcceptClient clientId) clientSock
|
|
|
|
ClientMessage clientId payload ->
|
|
|
|
case payload of
|
|
|
|
ClientQuit -> do
|
|
|
|
putStrLn $ "removing client " <> show clientId
|
|
|
|
let newClients = filter (\a -> fst a /= Just clientId) clients
|
2023-12-13 10:06:45 +00:00
|
|
|
STM.atomically $ do
|
|
|
|
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
|
|
|
|
let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
|
|
|
|
void $ STM.swapTMVar (scPlayers stateContainer) newPlayers
|
|
|
|
void $ STM.swapTMVar clientList newClients
|
2023-12-12 01:53:05 +00:00
|
|
|
ClientRequestWizard -> do
|
|
|
|
putStrLn "initializing new wizard"
|
|
|
|
let arena = rcMap readerContainer
|
|
|
|
initPos <- rollInitPosition arena
|
2024-02-02 08:07:11 +00:00
|
|
|
now <- liftIO getCurrentTime
|
2023-12-23 10:38:57 +00:00
|
|
|
let freshWizard = newWizard initPos
|
2023-12-13 10:06:45 +00:00
|
|
|
STM.atomically $ do
|
|
|
|
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
|
2023-12-23 10:38:57 +00:00
|
|
|
void $ STM.swapTMVar (scPlayers stateContainer) $
|
2024-02-02 08:07:11 +00:00
|
|
|
Player clientId freshWizard False now : currentPlayers
|
2023-12-12 01:53:05 +00:00
|
|
|
let clientSock = fromJust $ lookup (Just clientId) clients
|
2023-12-23 10:38:57 +00:00
|
|
|
sendMessage (ProvideInitialWizard freshWizard) clientSock
|
|
|
|
ClientReady -> do
|
|
|
|
putStrLn $ "client " <> show clientId <> " is ready!"
|
|
|
|
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} : otherPlayers
|
2023-12-12 01:53:05 +00:00
|
|
|
_ -> pure ()
|
2023-12-11 12:47:27 +00:00
|
|
|
|
2024-02-02 07:16:28 +00:00
|
|
|
sendPings :: Game ()
|
|
|
|
sendPings = do
|
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
maxTimeout <- asks rcClientMaxTimeout
|
|
|
|
framesPerPing <- asks rcFramesPerPing
|
|
|
|
fps <- asks rcFPS
|
2023-12-13 10:06:45 +00:00
|
|
|
stateContainer <- get
|
|
|
|
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
|
2023-12-20 07:12:22 +00:00
|
|
|
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
|
2023-12-13 10:06:45 +00:00
|
|
|
mapM_
|
2024-02-02 07:16:28 +00:00
|
|
|
(\(Player playerId (Wizard {}) readiness lastPong) -> do
|
|
|
|
let timeDiff = realToFrac $ diffUTCTime now lastPong
|
2024-02-02 08:07:11 +00:00
|
|
|
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
|
2024-02-02 07:16:28 +00:00
|
|
|
let clientSock = fromJust (lookup (Just playerId) sockets)
|
2024-02-02 08:07:11 +00:00
|
|
|
if timeDiff > realToFrac maxTimeout
|
2024-02-02 07:16:28 +00:00
|
|
|
then
|
2024-02-02 08:07:11 +00:00
|
|
|
liftIO $ disconnectClients [(Just playerId, clientSock)]
|
2024-02-02 07:16:28 +00:00
|
|
|
else do
|
2024-02-02 08:07:11 +00:00
|
|
|
random <- liftIO nextRandom
|
2024-02-02 07:16:28 +00:00
|
|
|
liftIO $ sendMessage
|
|
|
|
( Ping random
|
|
|
|
)
|
|
|
|
clientSock
|
2023-12-13 10:06:45 +00:00
|
|
|
)
|
|
|
|
players
|