261 lines
8 KiB
Haskell
261 lines
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 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
|
|
|
|
-- 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
|
|
clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
|
|
serverState <- gets scServerState
|
|
void $ liftIO $ installHandler
|
|
sigINT
|
|
(CatchOnce $ do
|
|
putStrLn "SIGINT caught, terminating…"
|
|
disconnectClients 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
|
|
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))
|
|
|
|
-- | 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
|
|
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 (\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
|
|
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
|
|
let clientSock = fromJust $ lookup (Just clientId) clients
|
|
sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock
|
|
_ -> pure ()
|
|
|
|
sendUpdates :: Game ()
|
|
sendUpdates = do
|
|
tileMap <- asks rcMap
|
|
stateContainer <- get
|
|
players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
|
|
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]
|
|
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
|
|
viewMatrix = M.fromList 9 9 $ map
|
|
(\(qr, qc) ->
|
|
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
|
|
clientSock = fromJust $ lookup (Just playerId) sockets
|
|
-- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
|
|
-- liftIO $ print initViewMatrix
|
|
liftIO $ sendMessage
|
|
(TickUpdate
|
|
{ tuWizard = wizard
|
|
, tuMapSlice = MapSlice
|
|
{ msViewMap = viewMatrix
|
|
, msContents = []
|
|
}
|
|
}
|
|
)
|
|
clientSock
|
|
)
|
|
players
|