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

262 lines
8 KiB
Haskell
Raw Normal View History

2023-12-10 01:02:09 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2023-12-09 12:58:59 +00:00
module Server.Communication where
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-20 08:04:50 +00:00
import Data.UUID
2023-12-10 16:00:50 +00:00
import Data.UUID.V4
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
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
2023-12-12 10:21:25 +00:00
:: FilePath
-> Game ()
terminateGameOnSigint path = do
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…"
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
where
disconnectClients = mapM_
2023-12-11 08:49:24 +00:00
(\(_, clientSocket) -> do
2023-12-11 09:48:25 +00:00
sendMessage ServerQuit clientSocket
2023-12-10 19:12:53 +00:00
close clientSocket
)
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
socketList <- gets scClientSockets
2023-12-10 08:53:56 +00:00
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
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-11 06:07:09 +00:00
msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson
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
)
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
let clientIdx = findIndex (\a -> fst a == Nothing) clients
let clientSock = snd $ clients !! fromJust clientIdx
let newClients = map
(\old@(muuid, oldClientSock) ->
if oldClientSock == clientSock && muuid == Nothing
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
2023-12-12 01:53:05 +00:00
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
let freshWIzard = newWizard initPos
STM.atomically $ do
currentPlayers <- STM.readTMVar (scPlayers stateContainer)
void $ STM.swapTMVar (scPlayers stateContainer) $ Player clientId freshWIzard : currentPlayers
2023-12-12 01:53:05 +00:00
let clientSock = fromJust $ lookup (Just clientId) clients
sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
_ -> pure ()
2023-12-11 12:47:27 +00:00
sendUpdates :: Game ()
sendUpdates = do
tileMap <- asks rcMap
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_
(\(player@(Player playerId wizard@(Wizard {..}))) -> do
let V2 wr wc = wizardPos
subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
2023-12-18 13:31:01 +00:00
leftBound = wizardRot + (pi / 4)
rightBound = wizardRot - (pi / 4)
leftLine row = cos leftBound * row
rightLine row = sin rightBound * row
correctionLeft = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
then floor
else ceiling
correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
then ceiling
else floor
2023-12-20 07:12:22 +00:00
viewMatrix = M.fromList 9 9 $ map
(\(qr, qc) ->
2023-12-18 13:31:01 +00:00
if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr))
&& qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr))
then
M.safeGet qr qc tileMap
else
Nothing
)
subCoords
2023-12-20 07:12:22 +00:00
clientSock = fromJust $ lookup (Just playerId) sockets
2023-12-18 13:31:01 +00:00
-- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
2023-12-20 07:12:22 +00:00
-- liftIO $ print initViewMatrix
liftIO $ sendMessage
(TickUpdate
{ tuWizard = wizard
, tuMapSlice = MapSlice
{ msViewMap = viewMatrix
, msContents = []
}
}
)
clientSock
)
players