107 lines
3 KiB
Haskell
107 lines
3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Server.Communication where
|
|
|
|
import Control.Concurrent
|
|
|
|
import qualified Control.Concurrent.STM as STM
|
|
|
|
import Control.Monad
|
|
|
|
import Control.Monad.IO.Class
|
|
|
|
import Control.Monad.RWS.Strict
|
|
|
|
import Network.Socket as Net
|
|
|
|
import System.IO
|
|
|
|
import System.Posix.Signals
|
|
|
|
-- internal imports
|
|
|
|
import Server.Types
|
|
import Server.Util
|
|
|
|
-- | 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)
|
|
-- aremoveIfExists path
|
|
sock <- socket AF_UNIX Stream defaultProtocol
|
|
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
|
|
clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
|
|
serverState <- gets scServerState
|
|
void $ liftIO $ installHandler
|
|
keyboardSignal
|
|
(CatchOnce $ do
|
|
void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
|
|
disconnectClients clients
|
|
threadDelay (10 ^ 6)
|
|
(SockAddrUnix path) <- getSocketName sock
|
|
close' sock
|
|
removeIfExists path
|
|
-- Raise SIGINT again so it does not get blocked
|
|
raiseSignal keyboardSignal
|
|
)
|
|
Nothing
|
|
where
|
|
disconnectClients = mapM_
|
|
(\(clientSocket, mThread) -> do
|
|
maybe (pure ()) killThread mThread
|
|
close' clientSocket
|
|
)
|
|
|
|
-- | Process incoming connection requests
|
|
processRequests :: Game ()
|
|
processRequests = do
|
|
mainSocket <- asks rcMainSocket
|
|
socketList <- gets scClientSockets
|
|
void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
|
|
where
|
|
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
|
|
|
|
-- | process incoming messages from clients
|
|
processMessages :: Game ()
|
|
processMessages = do
|
|
clientsVar <- gets scClientSockets
|
|
clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
|
|
newClients <- foldM
|
|
(\acc (clientSocket, mThread) ->
|
|
case mThread of
|
|
Nothing -> liftIO $ do
|
|
thread <- forkIO
|
|
(listenTo clientSocket)
|
|
pure $ (clientSocket, Just thread) : acc
|
|
Just _ -> liftIO $ do
|
|
pure acc
|
|
)
|
|
[]
|
|
clients
|
|
liftIO $ STM.atomically $ do
|
|
void $ STM.swapTMVar clientsVar newClients
|
|
where
|
|
listenTo clientSocket = do
|
|
connectionHandle <- socketToHandle clientSocket ReadMode
|
|
hSetBuffering connectionHandle LineBuffering
|
|
message <- hGetContents connectionHandle
|
|
putStr message
|
|
hClose connectionHandle
|