144 lines
4.3 KiB
Haskell
144 lines
4.3 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.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
|
|
queueList <- gets scClientQueues
|
|
void $ liftIO $ installHandler
|
|
sigINT
|
|
(CatchOnce $ do
|
|
putStrLn "SIGINT caught, terminating…"
|
|
queues <- liftIO $ STM.atomically $ STM.readTMVar queueList
|
|
disconnectClients clientList queues
|
|
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
|
|
:: STM.TMVar [ClientSocket]
|
|
-> [ClientQueue]
|
|
-> IO ()
|
|
disconnectClients clientSockets queues = do
|
|
putStrLn "server shutting down. Notifying all clients…"
|
|
mapM_
|
|
(\queue -> do
|
|
maybe
|
|
(pure ())
|
|
(\uuid -> do
|
|
putStrLn $ "notifying client: " <> show uuid
|
|
queueMessage ServerQuit uuid queues
|
|
sock <- do
|
|
socketList <- STM.atomically $ STM.readTMVar clientSockets
|
|
pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList
|
|
dropClient clientSockets (csSocket sock)
|
|
)
|
|
(cqUUID queue)
|
|
)
|
|
queues
|
|
|
|
|
|
-- | Process incoming connection requests
|
|
processRequests :: Game ()
|
|
processRequests = do
|
|
mainSocket <- asks rcMainSocket
|
|
serverQueue <- gets scMessageQueue
|
|
socketList <- gets scClientSockets
|
|
queueList <- gets scClientQueues
|
|
st <- gets scServerState
|
|
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queueList serverQueue st
|
|
where
|
|
acceptConnection mainSocket socketList queueList serverQueue st = do
|
|
putStrLn "Ready for new connection requests…"
|
|
eSock <- try $ accept mainSocket
|
|
case eSock of
|
|
Left (_ :: SomeException) ->
|
|
putStrLn "Main socket vanished!"
|
|
Right (clientSock, _) -> do
|
|
clientQueue <- STM.newTQueueIO
|
|
sockContainer <- STM.newTMVarIO clientSock
|
|
receiverThreadId <- liftIO $ forkIO $ forever $ do
|
|
receiveMessage sockContainer serverQueue
|
|
senderThreadId <- liftIO $ forkIO $ forever $ do
|
|
sendMessageQueue sockContainer clientQueue
|
|
print 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
|
|
)
|
|
putStrLn "accepted new connection"
|
|
-- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
|
|
-- unless abortCondition $
|
|
-- acceptConnection mainSocket socketList queue st
|
|
acceptConnection mainSocket socketList queueList serverQueue st
|