wizard-wipeout/src-server/Server/Communication.hs
2024-04-07 19:15:57 +02:00

324 lines
11 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Server.Communication where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.RWS.Strict
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.List
import Data.Maybe
import Data.UUID hiding (null)
import Data.UUID.V4
import Data.Time
import qualified Data.Vector.Storable as VS
import Foreign hiding (void)
import Network.Socket as Net
import System.Posix.Signals
-- internal imports
import Library.Types
import Server.Types
import Server.Util
-- | 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
bindSocket path = do
let sockAddr = SockAddrUnix path
unless (isSupportedSockAddr sockAddr)
(error $ "invalid socket path " <> path)
-- removeIfExists path
sock <- socket AF_UNIX Stream defaultProtocol
bind sock sockAddr
Net.listen sock 5
pure sock
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
:: Game ()
terminateGameOnSigint = do
sock <- asks rcMainSocket
clientList <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
serverState <- gets scServerState
void $ liftIO $ installHandler
sigINT
(CatchOnce $ do
putStrLn "SIGINT caught, terminating…"
disconnectClients clientList clients
close sock
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
)
Nothing
-- | Disconnect all connected clients gracefully by announcing the server quitting
disconnectClients
:: STM.TMVar [ClientComms]
-> [ClientComms]
-> IO ()
disconnectClients clientList = mapM_
(\client -> do
maybe
(pure ())
(\uuid -> do
sendMessage ServerQuit uuid clientList
dropClient clientList (ccSocket client)
)
(ccUUID client)
)
-- | Drops the client from internal management and closes its socket, if still present.
dropClient
:: STM.TMVar [ClientComms]
-> Socket
-> IO ()
dropClient clientList sock = do
mclient <- STM.atomically $ do
clients <- STM.readTMVar clientList
let mclient = find (\client -> ccSocket client == sock) clients
let reducedClients = filter (\client -> ccSocket client /= sock) clients
void $ STM.swapTMVar clientList reducedClients
pure mclient
maybe
(putStrLn $ "closing unknown socket: " <> show sock)
(\client -> do
putStrLn $ "dropping client: " <> show (ccUUID client)
killThread (ccListener client)
)
mclient
close sock
-- | Process incoming connection requests
processRequests :: Game ()
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…"
(clientSock, _) <- accept mainSocket
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"
-- | Sends a specified message through given socket to the client
sendMessage
:: ServerMessage
-> UUID
-> STM.TMVar [ClientComms]
-> IO ()
sendMessage msg uuid clientList = do
clients <- STM.atomically $ STM.readTMVar clientList
let msock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients
msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
putStrLn $ "Sending: " <> B8.unpack msgJson
maybe
(putStrLn $ "unknown client UUID: " <> show uuid)
(\sock ->
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
)
msock
-- | 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
mapM_
(handleMessage serverState readerContainer)
msgs
-- | receive a 'ClientMessage'
receiveMessage
:: Socket
-> STM.TQueue ClientMessage
-> STM.TMVar [ClientComms]
-> IO ()
receiveMessage sock queue clientList = do
let maxBufferLength = 4096
mmsg <- do
ptr <- mallocArray maxBufferLength
ebufferLength <-
try $ recvBuf sock ptr maxBufferLength
bufferLength <- case ebufferLength of
Left (_ :: IOException) -> do
putStrLn "Socket vanished, cleaning up…"
dropClient clientList sock
pure 0
Right len -> pure len
msg <- B.pack <$> peekArray bufferLength ptr
let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
free ptr
if bufferLength > 0
then
pure mJsonMsg
else
pure Nothing
maybe
(pure ())
(\msg -> do
putStrLn "PUT"
liftIO $ STM.atomically $ STM.writeTQueue queue msg
-- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
)
mmsg
-- | 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
let clientSock = ccSocket $ clients !! fromJust clientIdx
let 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 $ "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
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!"
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
Pong uuid -> do
-- let client = fromJust (find (\c -> ccUUID c == Just clientId) clients)
player <- STM.atomically $ do
players <- STM.readTMVar (scPlayers stateContainer)
pure $ head $ filter (\p -> playerId p == clientId) players
-- 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)
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)
sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
mapM_
(\player@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do
let timeDiff = realToFrac $ diffUTCTime now lastPongTime :: Float
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets
when (isJust clientSock) $
if timeDiff > realToFrac maxTimeout
then do
liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock)
put stateContainer
else do
random <- liftIO nextRandom
let newPong = (lastPongTime, random)
liftIO $ sendMessage
( Ping random
)
plId
(scClientSockets stateContainer)
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