157 lines
5 KiB
Haskell
157 lines
5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Server.Communication
|
|
( module Server.Communication
|
|
, module S
|
|
) where
|
|
|
|
import Control.Concurrent
|
|
|
|
import qualified Control.Concurrent.STM as STM
|
|
|
|
import Control.Exception
|
|
|
|
import Control.Monad
|
|
|
|
import Control.Monad.IO.Class
|
|
|
|
import Control.Monad.RWS.Strict
|
|
|
|
import Data.List (find)
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import Network.Socket as Net
|
|
|
|
import System.Posix.Signals
|
|
|
|
-- internal imports
|
|
|
|
import Library.Types
|
|
|
|
import Server.Communication.Handler as S
|
|
import Server.Communication.Receive as S
|
|
import Server.Communication.Send as S
|
|
import Server.Log (logPrintIO)
|
|
import Server.Types
|
|
|
|
-- | 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 0
|
|
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
|
|
curLevel <- asks rcLogLevel
|
|
serverState <- gets scServerState
|
|
clientList <- gets scClientSockets
|
|
queueList <- gets scClientQueues
|
|
void $ liftIO $ installHandler
|
|
sigINT
|
|
(CatchOnce $ do
|
|
logPrintIO curLevel Info "SIGINT caught, terminating…"
|
|
disconnectClients curLevel clientList queueList
|
|
threadDelay (10 ^ 6)
|
|
close sock
|
|
st <- STM.atomically $ STM.readTMVar serverState
|
|
void $ STM.atomically $ STM.swapTMVar serverState $ st
|
|
{ serverStop = True
|
|
}
|
|
)
|
|
Nothing
|
|
|
|
-- | Disconnect all connected clients gracefully by announcing the server quitting
|
|
disconnectClients
|
|
:: LogLevel
|
|
-> STM.TMVar [ClientSocket]
|
|
-> STM.TMVar [ClientQueue]
|
|
-> IO ()
|
|
disconnectClients curLevel clientSockets queueList = do
|
|
logPrintIO curLevel Info "server shutting down. Notifying all clients…"
|
|
queues <- STM.atomically $ STM.readTMVar queueList
|
|
mapM_
|
|
(\queue -> do
|
|
maybe
|
|
(pure ())
|
|
(\uuid -> do
|
|
logPrintIO curLevel Info $ "notifying client: " <> show uuid
|
|
queueMessage curLevel ServerQuit uuid queueList
|
|
threadDelay 1000 -- wait for the message to be actually sent
|
|
sock <- do
|
|
socketList <- STM.atomically $ STM.readTMVar clientSockets
|
|
pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList
|
|
dropClient curLevel clientSockets queueList (csSocket sock)
|
|
)
|
|
(cqUUID queue)
|
|
)
|
|
queues
|
|
|
|
|
|
-- | Process incoming connection requests
|
|
processRequests :: Game ()
|
|
processRequests = do
|
|
mainSocket <- asks rcMainSocket
|
|
curLevel <- asks rcLogLevel
|
|
serverQueue <- gets scMessageQueue
|
|
socketList <- gets scClientSockets
|
|
queueList <- gets scClientQueues
|
|
st <- gets scServerState
|
|
void $ liftIO $ forkIO $ acceptConnection curLevel mainSocket socketList queueList serverQueue st
|
|
where
|
|
acceptConnection curLevel mainSocket socketList queueList serverQueue st = do
|
|
logPrintIO curLevel Info "Ready for new connection requests…"
|
|
eSock <- try $ accept mainSocket
|
|
case eSock of
|
|
Left (_ :: SomeException) ->
|
|
logPrintIO curLevel Warning "Main socket vanished!"
|
|
Right (clientSock, _) -> do
|
|
clientQueue <- STM.newTQueueIO
|
|
sockContainer <- STM.newTMVarIO clientSock
|
|
receiverThreadId <- liftIO $ do
|
|
t <- forkIO $ do
|
|
threadDelay $ 10 ^ 6
|
|
forever $ receiveMessage curLevel socketList queueList sockContainer serverQueue
|
|
logPrintIO curLevel Verbose "enabled listener thread"
|
|
pure t
|
|
senderThreadId <- liftIO $ do
|
|
t <- forkIO $ do
|
|
threadDelay $ 10 ^ 6
|
|
forever $ sendMessageQueue curLevel sockContainer clientQueue
|
|
logPrintIO curLevel Verbose "enabled sender thread"
|
|
pure t
|
|
logPrintIO curLevel Verbose $ show clientSock
|
|
liftIO $ STM.atomically $ do
|
|
slist <- STM.takeTMVar socketList
|
|
STM.putTMVar
|
|
socketList
|
|
(ClientSocket
|
|
Nothing
|
|
clientSock
|
|
receiverThreadId
|
|
senderThreadId
|
|
: slist
|
|
)
|
|
qlist <- STM.takeTMVar queueList
|
|
STM.putTMVar queueList
|
|
(ClientQueue
|
|
Nothing
|
|
clientQueue
|
|
: qlist
|
|
)
|
|
logPrintIO curLevel Info "accepted new connection"
|
|
-- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
|
|
-- unless abortCondition $
|
|
-- acceptConnection mainSocket socketList queue st
|
|
acceptConnection curLevel mainSocket socketList queueList serverQueue st
|