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

112 lines
3.1 KiB
Haskell
Raw Normal View History

2023-12-10 01:02:09 +00:00
{-# LANGUAGE OverloadedStrings #-}
2023-12-09 12:58:59 +00:00
module Server.Communication where
import Control.Concurrent
import qualified Control.Concurrent.STM as STM
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.Loops
2023-12-10 01:02:09 +00:00
import Control.Monad.RWS.Strict
import Data.Maybe (maybe)
2023-12-10 01:02:09 +00:00
import Network.Socket as Net
import System.IO
2023-12-09 12:58:59 +00:00
import System.Posix.Signals
-- internal imports
2023-12-10 01:02:09 +00:00
import Server.Types
2023-12-09 12:58:59 +00:00
import Server.Util
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)
2023-12-09 13:18:10 +00:00
-- aremoveIfExists 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
clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
serverState <- gets scServerState
void $ liftIO $ installHandler
2023-12-09 12:58:59 +00:00
keyboardSignal
(CatchOnce $ do
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
disconnectClients clients
threadDelay (10 ^ 6)
2023-12-09 12:58:59 +00:00
(SockAddrUnix path) <- getSocketName sock
close' sock
removeIfExists path
2023-12-09 13:11:37 +00:00
-- Raise SIGINT again so it does not get blocked
2023-12-09 12:58:59 +00:00
raiseSignal keyboardSignal
)
Nothing
where
disconnectClients = mapM_
(\(clientSocket, mThread) -> do
maybe (pure ()) killThread mThread
close' clientSocket
)
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
socketList <- gets scClientSockets
2023-12-10 08:53:56 +00:00
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
where
2023-12-10 08:53:56 +00:00
acceptConnection mainSocket socketList = do
(clientSock, _) <- accept mainSocket
putStrLn "accepted new connection"
liftIO $ STM.atomically $ do
list <- STM.takeTMVar socketList
STM.putTMVar socketList ((clientSock, Nothing) : list)
acceptConnection mainSocket socketList
2023-12-10 01:02:09 +00:00
-- | process incoming messages from clients
processMessages :: Game ()
2023-12-10 01:02:09 +00:00
processMessages = do
clientsVar <- gets scClientSockets
2023-12-10 08:53:56 +00:00
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
newClients <- foldM
(\acc (clientSocket, mThread) ->
case mThread of
Nothing -> liftIO $ do
thread <- forkIO
2023-12-10 08:53:56 +00:00
(listenTo clientSocket)
pure $ (clientSocket, Just thread) : acc
Just _ -> liftIO $ do
pure acc
2023-12-10 01:02:09 +00:00
)
2023-12-10 08:53:56 +00:00
[]
clients
liftIO $ STM.atomically $ do
void $ STM.swapTMVar clientsVar newClients
where
2023-12-10 08:53:56 +00:00
listenTo clientSocket = do
connectionHandle <- socketToHandle clientSocket ReadMode
hSetBuffering connectionHandle LineBuffering
message <- hGetContents connectionHandle
putStr message
2023-12-10 08:53:56 +00:00
hClose connectionHandle