126 lines
3.6 KiB
Haskell
126 lines
3.6 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 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.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
|
|
serverState <- gets scServerState
|
|
clientList <- gets scClientSockets
|
|
void $ liftIO $ installHandler
|
|
sigINT
|
|
(CatchOnce $ do
|
|
putStrLn "SIGINT caught, terminating…"
|
|
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
|
|
disconnectClients clientList clients
|
|
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
|
|
:: STM.TMVar [ClientComms]
|
|
-> [ClientComms]
|
|
-> IO ()
|
|
disconnectClients clientList clients = do
|
|
putStrLn "server shutting down. Notifying all clients…"
|
|
mapM_
|
|
(\client -> do
|
|
maybe
|
|
(pure ())
|
|
(\uuid -> do
|
|
queueMessage ServerQuit uuid clientList
|
|
dropClient clientList (ccSocket client)
|
|
)
|
|
(ccUUID client)
|
|
)
|
|
clients
|
|
|
|
|
|
-- | Process incoming connection requests
|
|
processRequests :: Game ()
|
|
processRequests = do
|
|
mainSocket <- asks rcMainSocket
|
|
queue <- gets scMessageQueue
|
|
socketList <- gets scClientSockets
|
|
st <- gets scServerState
|
|
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
|
|
where
|
|
acceptConnection mainSocket socketList queue st = do
|
|
putStrLn "Ready for new connection requests…"
|
|
eSock <- try $ accept mainSocket
|
|
case eSock of
|
|
Left (_ :: SomeException) ->
|
|
putStrLn "Main socket vanished!"
|
|
Right (clientSock, _) -> do
|
|
messageQueue <- STM.newTQueueIO
|
|
sockCOntainer <- STM.newTMVarIO clientSock
|
|
clientWriteThreadId <- liftIO $ forkIO $ forever $ do
|
|
receiveMessage sockCOntainer queue socketList
|
|
clientListenThreadId <- liftIO $ forkIO $ forever $ do
|
|
sendMessageQueue sockCOntainer messageQueue
|
|
print clientSock
|
|
liftIO $ STM.atomically $ do
|
|
list <- STM.takeTMVar socketList
|
|
STM.putTMVar
|
|
socketList
|
|
(ClientComms
|
|
Nothing
|
|
clientSock
|
|
messageQueue
|
|
clientWriteThreadId
|
|
clientListenThreadId
|
|
: list
|
|
)
|
|
putStrLn "accepted new connection"
|
|
abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
|
|
unless abortCondition $
|
|
acceptConnection mainSocket socketList queue st
|