wizard-wipeout/src-server/Server/Communication.hs
2023-12-12 02:53:05 +01:00

227 lines
6.3 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
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 qualified Data.Matrix as M
import Data.Maybe
import Data.UUID
import Data.UUID.V4
import qualified Data.Vector.Storable as VS
import Foreign hiding (void)
import Linear
import Network.Socket as Net
import System.Posix.Signals
import System.Random (randomRIO)
-- 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
:: Game ()
terminateGameOnSigint = do
sock <- asks rcMainSocket
clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
serverState <- gets scServerState
void $ liftIO $ installHandler
keyboardSignal
(CatchOnce $ do
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
disconnectClients clients
threadDelay (10 ^ 6)
(SockAddrUnix path) <- getSocketName sock
close sock
removeIfExists path
-- Raise SIGINT again so it does not get blocked
raiseSignal keyboardSignal
)
Nothing
where
disconnectClients = mapM_
(\(_, clientSocket) -> do
sendMessage ServerQuit clientSocket
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 msgJson
putStrLn $ "sending: " <> B8.unpack msgJson
VS.unsafeWith
msgVector
(\ptr -> void $ sendBuf sock ptr (VS.length msgVector))
-- | process incoming messages from clients
processMessages :: Game ()
processMessages = do
clientsVar <- gets scClientSockets
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
queue <- gets scMessageQueue
serverState <- get
readerContainer <- ask
mapM_
(\(uuid, clientSocket) -> void $ liftIO $ forkIO $ do
receiveMessage clientSocket queue
msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
mapM_
(handleMessage serverState readerContainer)
msgs
)
clients
-- | 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 (\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
void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
ClientRequestWizard -> do
putStrLn "initializing new wizard"
let arena = rcMap readerContainer
initPos <- rollInitPosition arena
let clientSock = fromJust $ lookup (Just clientId) clients
sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
_ -> pure ()
newWizard
:: Position
-> Wizard
newWizard pos =
Wizard
{ wizardWands = []
, wizardRot = 0
, wizardPos = pos
, wizardMana = 100
, wizardHealth = 100
, wizardEffects = []
}
rollInitPosition
:: ServerMap
-> IO Position
rollInitPosition arena = do
r <- randomRIO (1, M.nrows arena)
c <- randomRIO (1, M.ncols arena)
if arena M.! (r, c) == Air
then
pure $ (fromIntegral <$> V2 r c) + V2 0.5 0.5
else
rollInitPosition arena