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

299 lines
9.8 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Server.Communication where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
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)
-- aremoveIfExists 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
:: FilePath
-> Game ()
terminateGameOnSigint path = 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
removeIfExists path
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
-- Raise SIGINT again so it does not get blocked
-- raiseSignal sigINT
)
Nothing
disconnectClients
:: STM.TMVar [(Maybe UUID, Socket)]
-> [(Maybe UUID, Socket)]
-> IO ()
disconnectClients clientList = mapM_
(\client@(_, clientSocket) -> do
sendMessage ServerQuit clientSocket
dropClient clientList client
)
dropClient
:: STM.TMVar [(Maybe UUID, Socket)]
-> (Maybe UUID, Socket)
-> IO ()
dropClient clientList (uuid, clientSocket) = do
STM.atomically $ do
clients <- STM.readTMVar clientList
let reducedClients = filter ((/= uuid) . fst) clients
void $ STM.swapTMVar clientList reducedClients
putStrLn $ "dropping client " <> show uuid
close clientSocket
-- | Process incoming connection requests
processRequests :: Game ()
processRequests = do
mainSocket <- asks rcMainSocket
socketList <- gets scClientSockets
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
where
acceptConnection mainSocket socketList = do
putStrLn "accepting new connections…"
(clientSock, _) <- accept mainSocket
liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList
STM.putTMVar socketList ((Nothing, clientSock) : list)
putStrLn "accepted new connection"
acceptConnection mainSocket socketList
-- | Sends a specified message through given socket to the client
sendMessage
:: ServerMessage
-> Socket
-> IO ()
sendMessage msg sock = do
let msgJson = A.encode msg
msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
-- putStrLn $ "sending: " <> B8.unpack msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
-- | receive incoming messages from clients
receiveMessages
:: STM.TMVar [(Maybe UUID, Socket)]
-> STM.TQueue ClientMessage
-> IO ()
receiveMessages clientsVar queue = do
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
mapM_
(\(_, clientSocket) -> do
receiveMessage clientSocket queue
)
clients
-- | handle received messages
handleMessages :: Game ()
handleMessages = do
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
emptyState <- liftIO $ STM.atomically $ STM.isEmptyTQueue queue
unless emptyState $ do
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
void $ liftIO $ do
mapM_
(handleMessage serverState readerContainer)
msgs
-- | receive a 'ClientMessage'
receiveMessage
:: Socket
-> STM.TQueue ClientMessage
-> IO ()
receiveMessage sock queue = do
let maxBufferLength = 4096
mmsg <- do
ptr <- mallocArray maxBufferLength
bufferLength <- recvBuf sock ptr maxBufferLength
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
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 following: " <> show msg
case msg of
IdRequest -> do
clientId <- nextRandom
let clientIdx = findIndex (isNothing . fst) clients
let clientSock = snd $ clients !! fromJust clientIdx
let newClients = map
(\old@(muuid, oldClientSock) ->
if oldClientSock == clientSock && isNothing muuid
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
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
let clientSock = fromJust $ lookup (Just clientId) clients
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
Pong uuid -> do
let client = fromJust (lookup (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)
_ -> pure ()
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
when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do
let clientSock = lookup (Just plId) sockets
when (isJust clientSock) $
if timeDiff > realToFrac maxTimeout
then do
liftIO $ dropClient (scClientSockets stateContainer) (Just plId, fromJust clientSock)
put stateContainer
else do
random <- liftIO nextRandom
let newPong = (lastPongTime, random)
liftIO $ sendMessage
( Ping random
)
(fromJust clientSock)
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