323 lines
11 KiB
Haskell
323 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
|