wizard-wipeout/src-server/Server/Communication.hs

324 lines
11 KiB
Haskell
Raw Normal View History

2023-12-10 01:02:09 +00:00
{-# LANGUAGE OverloadedStrings #-}
2023-12-09 12:58:59 +00:00
module Server.Communication where
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)
-- 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
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
:: Game ()
terminateGameOnSigint = do
sock <- asks rcMainSocket
2024-02-03 17:01:45 +00:00
clientList <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
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
2023-12-20 07:12:22 +00:00
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False 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
:: STM.TMVar [ClientComms]
-> [ClientComms]
2024-02-02 07:16:28 +00:00
-> IO ()
2024-02-03 17:01:45 +00:00
disconnectClients clientList = mapM_
(\client -> do
2024-03-29 09:34:15 +00:00
maybe
(pure ())
(\uuid -> do
sendMessage ServerQuit uuid clientList
dropClient clientList (ccSocket client)
2024-03-29 09:34:15 +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
:: STM.TMVar [ClientComms]
-> Socket
2024-02-02 14:50:57 +00:00
-> IO ()
dropClient clientList sock = do
mclient <- STM.atomically $ do
2024-02-03 17:01:45 +00:00
clients <- STM.readTMVar clientList
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
pure mclient
2024-03-29 09:34:15 +00:00
maybe
(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
processRequests :: Game ()
2023-12-10 01:02:09 +00:00
processRequests = do
mainSocket <- asks rcMainSocket
queue <- gets scMessageQueue
socketList <- gets scClientSockets
void $ liftIO $ forkIO $ forever $ acceptConnection mainSocket socketList queue
where
acceptConnection mainSocket socketList queue = do
putStrLn "New connection request incoming…"
2023-12-10 08:53:56 +00:00
(clientSock, _) <- accept mainSocket
clientThreadId <- liftIO $ forkIO $ forever $ do
receiveMessage clientSock queue socketList
2023-12-10 08:53:56 +00:00
liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList
STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list)
2023-12-11 08:49:24 +00:00
putStrLn "accepted new connection"
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
-> 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
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` '>'))
putStrLn $ "Sending: " <> B8.unpack msgJson
2024-03-29 09:34:15 +00:00
maybe
(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
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
-> STM.TMVar [ClientComms]
2023-12-11 09:48:25 +00:00
-> IO ()
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…"
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
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
let clientIdx = findIndex (isNothing . ccUUID) clients
let clientSock = ccSocket $ clients !! fromJust clientIdx
2023-12-12 01:53:05 +00:00
let newClients = map
(\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
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
let newClients = filter (\a -> ccUUID a /= Just clientId) clients
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
2024-02-02 15:34:50 +00:00
uuid <- nextRandom
2023-12-23 10:38:57 +00:00
let freshWizard = newWizard initPos
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
-- let client = fromJust (find (\c -> ccUUID c == Just clientId) clients)
2024-02-02 15:34:50 +00:00
player <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer)
pure $ head $ filter (\p -> playerId p == clientId) players
2024-03-29 03:14:21 +00:00
-- if snd (playerLastPong player) /= uuid
-- then do
-- putStrLn $ "dropping client " <> show clientId
-- dropClient clientList (Just clientId, 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)
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
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)
mapM_
2024-03-29 03:14:21 +00:00
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
2024-02-02 08:07:11 +00:00
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
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
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-03-29 03:14:21 +00:00
let newPong = (lastPongTime, 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
)
players