wizard-wipeout/src-server/Server/Communication.hs

113 lines
3.2 KiB
Haskell
Raw Normal View History

2023-12-10 01:02:09 +00:00
{-# LANGUAGE OverloadedStrings #-}
2024-05-01 21:52:49 +00:00
module Server.Communication
( module Server.Communication
, module S
) where
2023-12-09 12:58:59 +00:00
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
2024-05-01 21:53:12 +00:00
import Control.Exception
2024-03-29 09:34:15 +00:00
2023-12-09 12:58:59 +00:00
import Control.Monad
2023-12-10 01:02:09 +00:00
import Control.Monad.IO.Class
import Control.Monad.RWS.Strict
import Network.Socket as Net
2023-12-09 12:58:59 +00:00
import System.Posix.Signals
-- internal imports
2023-12-10 16:00:50 +00:00
import Library.Types
2024-05-01 21:52:49 +00:00
import Server.Communication.Handler as S
import Server.Communication.Receive as S
import Server.Communication.Send as S
2023-12-10 01:02:09 +00:00
import Server.Types
2023-12-09 12:58:59 +00:00
2023-12-09 13:18:10 +00:00
-- | 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
2023-12-09 12:58:59 +00:00
bindSocket path = do
let sockAddr = SockAddrUnix path
unless (isSupportedSockAddr sockAddr)
(error $ "invalid socket path " <> path)
-- removeIfExists path
2023-12-10 01:02:09 +00:00
sock <- socket AF_UNIX Stream defaultProtocol
2023-12-09 12:58:59 +00:00
bind sock sockAddr
2023-12-10 01:02:09 +00:00
Net.listen sock 5
2023-12-09 12:58:59 +00:00
pure sock
-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
:: Game ()
terminateGameOnSigint = do
sock <- asks rcMainSocket
serverState <- gets scServerState
2024-04-19 18:18:49 +00:00
clientList <- gets scClientSockets
void $ liftIO $ installHandler
2023-12-12 10:21:25 +00:00
sigINT
2023-12-09 12:58:59 +00:00
(CatchOnce $ do
2023-12-12 10:21:25 +00:00
putStrLn "SIGINT caught, terminating…"
2024-04-19 18:18:49 +00:00
clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
2024-02-03 17:01:45 +00:00
disconnectClients clientList clients
2023-12-10 19:12:53 +00:00
close sock
2024-04-08 01:50:12 +00:00
st <- STM.atomically $ STM.readTMVar serverState
void $ STM.atomically $ STM.swapTMVar serverState $ st
{ serverStop = True
}
2023-12-09 12:58:59 +00:00
)
2023-12-12 12:44:33 +00:00
Nothing
2024-02-02 07:16:28 +00:00
2024-03-29 09:34:15 +00:00
-- | Disconnect all connected clients gracefully by announcing the server quitting
2024-02-02 07:16:28 +00:00
disconnectClients
:: STM.TMVar [ClientComms]
-> [ClientComms]
2024-02-02 07:16:28 +00:00
-> IO ()
2024-04-19 18:18:49 +00:00
disconnectClients clientList clients = do
putStrLn "server shutting down. Notifying all clients…"
mapM_
(\client -> do
maybe
(pure ())
(\uuid -> do
sendMessage ServerQuit uuid clientList
dropClient clientList (ccSocket client)
)
(ccUUID client)
)
clients
2023-12-10 01:02:09 +00:00
2024-02-02 14:50:57 +00:00
2023-12-10 01:02:09 +00:00
-- | Process incoming connection requests
processRequests :: Game ()
2023-12-10 01:02:09 +00:00
processRequests = do
mainSocket <- asks rcMainSocket
queue <- gets scMessageQueue
socketList <- gets scClientSockets
2024-04-08 01:50:12 +00:00
st <- gets scServerState
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
where
2024-04-08 01:50:12 +00:00
acceptConnection mainSocket socketList queue st = do
2024-04-08 00:42:07 +00:00
putStrLn "Ready for new connection requests…"
2024-04-19 18:18:49 +00:00
eSock <- try $ accept mainSocket
case eSock of
2024-04-08 01:50:12 +00:00
Left (_ :: SomeException) ->
putStrLn "Main socket vanished!"
Right (clientSock, _) -> do
clientThreadId <- liftIO $ forkIO $ forever $ do
receiveMessage clientSock queue socketList
liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList
2024-04-19 18:18:49 +00:00
STM.putTMVar socketList (ClientComms Nothing clientSock clientThreadId : list)
2024-04-08 01:50:12 +00:00
putStrLn "accepted new connection"
abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
unless abortCondition $
acceptConnection mainSocket socketList queue st