2023-12-10 01:02:09 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
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
|
|
|
|
|
2024-03-29 09:34:15 +00:00
|
|
|
import Control.Exception.Base
|
|
|
|
|
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
|
|
|
|
|
|
|
|
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-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)
|
2024-04-06 00:18:08 +00:00
|
|
|
-- removeIfExists 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
|
2024-04-06 00:18:08 +00:00
|
|
|
:: Game ()
|
|
|
|
terminateGameOnSigint = do
|
2023-12-10 05:57:48 +00:00
|
|
|
sock <- asks rcMainSocket
|
2024-02-03 17:01:45 +00:00
|
|
|
clientList <- gets scClientSockets
|
|
|
|
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
|
2023-12-10 05:57:48 +00:00
|
|
|
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…"
|
2024-02-03 17:01:45 +00:00
|
|
|
disconnectClients clientList clients
|
2023-12-10 19:12:53 +00:00
|
|
|
close sock
|
2024-04-08 01:50:12 +00:00
|
|
|
st <- STM.atomically $ STM.readTMVar serverState
|
|
|
|
void $ STM.atomically $ STM.swapTMVar serverState $ st
|
|
|
|
{ serverStop = True
|
|
|
|
}
|
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
|
|
|
|
2024-03-29 09:34:15 +00:00
|
|
|
-- | Disconnect all connected clients gracefully by announcing the server quitting
|
2024-02-02 07:16:28 +00:00
|
|
|
disconnectClients
|
2024-04-06 00:18:08 +00:00
|
|
|
:: STM.TMVar [ClientComms]
|
|
|
|
-> [ClientComms]
|
2024-02-02 07:16:28 +00:00
|
|
|
-> IO ()
|
2024-02-03 17:01:45 +00:00
|
|
|
disconnectClients clientList = mapM_
|
2024-04-06 00:18:08 +00:00
|
|
|
(\client -> do
|
2024-03-29 09:34:15 +00:00
|
|
|
maybe
|
|
|
|
(pure ())
|
|
|
|
(\uuid -> do
|
|
|
|
sendMessage ServerQuit uuid clientList
|
2024-04-06 00:18:08 +00:00
|
|
|
dropClient clientList (ccSocket client)
|
2024-03-29 09:34:15 +00:00
|
|
|
)
|
2024-04-06 00:18:08 +00:00
|
|
|
(ccUUID client)
|
2024-02-02 07:16:28 +00:00
|
|
|
)
|
2023-12-10 01:02:09 +00:00
|
|
|
|
2024-03-29 09:34:15 +00:00
|
|
|
-- | Drops the client from internal management and closes its socket, if still present.
|
2024-02-02 15:34:50 +00:00
|
|
|
dropClient
|
2024-04-06 00:18:08 +00:00
|
|
|
:: STM.TMVar [ClientComms]
|
|
|
|
-> Socket
|
2024-02-02 14:50:57 +00:00
|
|
|
-> IO ()
|
2024-04-06 00:18:08 +00:00
|
|
|
dropClient clientList sock = do
|
|
|
|
mclient <- STM.atomically $ do
|
2024-02-03 17:01:45 +00:00
|
|
|
clients <- STM.readTMVar clientList
|
2024-04-06 00:18:08 +00:00
|
|
|
let mclient = find (\client -> ccSocket client == sock) clients
|
|
|
|
let reducedClients = filter (\client -> ccSocket client /= sock) clients
|
2024-02-03 17:01:45 +00:00
|
|
|
void $ STM.swapTMVar clientList reducedClients
|
2024-04-06 00:18:08 +00:00
|
|
|
pure mclient
|
2024-03-29 09:34:15 +00:00
|
|
|
maybe
|
2024-04-06 00:18:08 +00:00
|
|
|
(putStrLn $ "closing unknown socket: " <> show sock)
|
|
|
|
(\client -> do
|
|
|
|
putStrLn $ "dropping client: " <> show (ccUUID client)
|
|
|
|
killThread (ccListener client)
|
|
|
|
)
|
|
|
|
mclient
|
|
|
|
close sock
|
2024-02-02 14:50:57 +00:00
|
|
|
|
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
|
2024-04-06 00:18:08 +00:00
|
|
|
queue <- gets scMessageQueue
|
2023-12-10 05:57:48 +00:00
|
|
|
socketList <- gets scClientSockets
|
2024-04-08 01:50:12 +00:00
|
|
|
st <- gets scServerState
|
|
|
|
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
|
2023-12-10 05:57:48 +00:00
|
|
|
where
|
2024-04-08 01:50:12 +00:00
|
|
|
acceptConnection mainSocket socketList queue st = do
|
2024-04-08 00:42:07 +00:00
|
|
|
putStrLn "Ready for new connection requests…"
|
2024-04-08 01:50:12 +00:00
|
|
|
esock <- try $ accept mainSocket
|
|
|
|
case esock of
|
|
|
|
Left (_ :: SomeException) ->
|
|
|
|
putStrLn "Main socket vanished!"
|
|
|
|
Right (clientSock, _) -> do
|
|
|
|
clientThreadId <- liftIO $ forkIO $ forever $ do
|
|
|
|
receiveMessage clientSock queue socketList
|
|
|
|
liftIO $ STM.atomically $ do
|
|
|
|
list <- STM.takeTMVar socketList
|
|
|
|
STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
|
|
|
|
putStrLn "accepted new connection"
|
|
|
|
abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
|
|
|
|
unless abortCondition $
|
|
|
|
acceptConnection mainSocket socketList queue st
|
|
|
|
|
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
|
2024-03-29 09:34:15 +00:00
|
|
|
-> UUID
|
2024-04-06 00:18:08 +00:00
|
|
|
-> STM.TMVar [ClientComms]
|
2023-12-10 16:00:50 +00:00
|
|
|
-> IO ()
|
2024-03-29 09:34:15 +00:00
|
|
|
sendMessage msg uuid clientList = do
|
|
|
|
clients <- STM.atomically $ STM.readTMVar clientList
|
2024-04-06 00:18:08 +00:00
|
|
|
let msock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
|
2024-03-29 09:34:15 +00:00
|
|
|
msgJson = A.encode msg
|
2023-12-23 10:38:57 +00:00
|
|
|
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
|
2024-04-06 00:18:08 +00:00
|
|
|
putStrLn $ "Sending: " <> B8.unpack msgJson
|
2024-03-29 09:34:15 +00:00
|
|
|
maybe
|
2024-04-06 00:18:08 +00:00
|
|
|
(putStrLn $ "unknown client UUID: " <> show uuid)
|
2024-03-29 09:34:15 +00:00
|
|
|
(\sock ->
|
|
|
|
VS.unsafeWith
|
|
|
|
msgVector
|
|
|
|
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
|
|
|
|
)
|
|
|
|
msock
|
2023-12-10 16:00:50 +00:00
|
|
|
|
2023-12-12 02:31:57 +00:00
|
|
|
-- | handle received messages
|
|
|
|
handleMessages :: Game ()
|
|
|
|
handleMessages = do
|
|
|
|
queue <- gets scMessageQueue
|
|
|
|
serverState <- get
|
|
|
|
readerContainer <- ask
|
2024-04-06 00:18:08 +00:00
|
|
|
liftIO $ do
|
|
|
|
msgs <- STM.atomically $ do
|
|
|
|
emptyState <- STM.isEmptyTQueue queue
|
|
|
|
if emptyState
|
|
|
|
then
|
|
|
|
pure []
|
|
|
|
else
|
|
|
|
STM.flushTQueue queue
|
|
|
|
unless (null msgs) $ putStrLn "GET"
|
|
|
|
void $ do
|
2024-03-29 03:14:21 +00:00
|
|
|
mapM_
|
|
|
|
(handleMessage serverState readerContainer)
|
|
|
|
msgs
|
2023-12-12 02:31:57 +00:00
|
|
|
|
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
|
2024-04-06 00:18:08 +00:00
|
|
|
-> STM.TMVar [ClientComms]
|
2023-12-11 09:48:25 +00:00
|
|
|
-> IO ()
|
2024-04-06 00:18:08 +00:00
|
|
|
receiveMessage sock queue clientList = 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
|
2024-03-29 09:34:15 +00:00
|
|
|
ebufferLength <-
|
|
|
|
try $ recvBuf sock ptr maxBufferLength
|
|
|
|
bufferLength <- case ebufferLength of
|
|
|
|
Left (_ :: IOException) -> do
|
|
|
|
putStrLn "Socket vanished, cleaning up…"
|
2024-04-06 00:18:08 +00:00
|
|
|
dropClient clientList sock
|
2024-03-29 09:34:15 +00:00
|
|
|
pure 0
|
|
|
|
Right len -> pure len
|
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
|
2024-04-06 00:18:08 +00:00
|
|
|
putStrLn "PUT"
|
2023-12-11 08:49:24 +00:00
|
|
|
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
|
2024-04-07 17:15:57 +00:00
|
|
|
putStrLn $ "Handling: " <> show msg
|
2023-12-12 01:53:05 +00:00
|
|
|
case msg of
|
|
|
|
IdRequest -> do
|
|
|
|
clientId <- nextRandom
|
2024-04-06 00:18:08 +00:00
|
|
|
let clientIdx = findIndex (isNothing . ccUUID) clients
|
|
|
|
let clientSock = ccSocket $ clients !! fromJust clientIdx
|
2023-12-12 01:53:05 +00:00
|
|
|
let newClients = map
|
2024-04-06 00:18:08 +00:00
|
|
|
(\old@(ClientComms muuid oldClientSock _) ->
|
2024-02-02 07:16:28 +00:00
|
|
|
if oldClientSock == clientSock && isNothing muuid
|
2023-12-12 01:53:05 +00:00
|
|
|
then
|
2024-04-06 00:18:08 +00:00
|
|
|
old
|
|
|
|
{ ccUUID = Just clientId
|
|
|
|
}
|
2023-12-12 01:53:05 +00:00
|
|
|
else
|
|
|
|
old
|
|
|
|
)
|
|
|
|
clients
|
|
|
|
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
|
|
|
|
putStrLn $ "Accepted Client with UUID " <> show clientId
|
2024-03-29 09:34:15 +00:00
|
|
|
sendMessage (AcceptClient clientId) clientId clientList
|
2023-12-12 01:53:05 +00:00
|
|
|
ClientMessage clientId payload ->
|
|
|
|
case payload of
|
|
|
|
ClientQuit -> do
|
|
|
|
putStrLn $ "removing client " <> show clientId
|
2024-04-06 00:18:08 +00:00
|
|
|
let newClients = filter (\a -> ccUUID a /= Just clientId) clients
|
2024-04-17 17:44:47 +00:00
|
|
|
client = find (\a -> ccUUID 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
|
2024-04-17 17:44:47 +00:00
|
|
|
close (ccSocket $ fromJust client)
|
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
|
2024-02-02 15:34:50 +00:00
|
|
|
uuid <- nextRandom
|
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 15:34:50 +00:00
|
|
|
Player clientId freshWizard False (now, uuid) : currentPlayers
|
2024-03-29 09:34:15 +00:00
|
|
|
sendMessage (ProvideInitialWizard freshWizard) clientId clientList
|
2023-12-23 10:38:57 +00:00
|
|
|
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
|
2024-02-02 15:34:50 +00:00
|
|
|
Pong uuid -> do
|
2024-04-08 01:50:12 +00:00
|
|
|
let mclient = find (\c -> ccUUID c == Just clientId) clients
|
|
|
|
maybe
|
|
|
|
(putStrLn $ "Who is " <> show uuid <> "?")
|
|
|
|
(\client -> 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 do
|
|
|
|
putStrLn $ "dropping client " <> show clientId
|
|
|
|
dropClient clientList (ccSocket client)
|
|
|
|
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
|
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-03-29 03:14:21 +00:00
|
|
|
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
|
2024-04-06 00:18:08 +00:00
|
|
|
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
|
2024-02-02 08:07:11 +00:00
|
|
|
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
|
2024-04-06 00:18:08 +00:00
|
|
|
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
|
2024-02-03 17:01:45 +00:00
|
|
|
when (isJust clientSock) $
|
|
|
|
if timeDiff > realToFrac maxTimeout
|
2024-03-29 03:14:21 +00:00
|
|
|
then do
|
2024-04-06 00:18:08 +00:00
|
|
|
liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
|
2024-03-29 03:14:21 +00:00
|
|
|
put stateContainer
|
2024-02-03 17:01:45 +00:00
|
|
|
else do
|
|
|
|
random <- liftIO nextRandom
|
2024-04-08 01:50:12 +00:00
|
|
|
let newPong = (now, random)
|
2024-02-03 17:01:45 +00:00
|
|
|
liftIO $ sendMessage
|
|
|
|
( Ping random
|
|
|
|
)
|
2024-03-29 09:34:15 +00:00
|
|
|
plId
|
|
|
|
(scClientSockets stateContainer)
|
2024-03-29 03:14:21 +00:00
|
|
|
let newPlayer = player
|
|
|
|
{ playerLastPong = newPong
|
|
|
|
}
|
|
|
|
otherPlayers = filter (\a -> playerId a /= plId) players
|
|
|
|
liftIO $ void $ STM.atomically $
|
|
|
|
STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers)
|
|
|
|
put stateContainer
|
2023-12-13 10:06:45 +00:00
|
|
|
)
|
|
|
|
players
|