{-# LANGUAGE OverloadedStrings #-} module Server.Communication ( module Server.Communication , module S ) where import Control.Concurrent import qualified Control.Concurrent.STM as STM import Control.Exception.Base 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 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 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 sendMessage 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 clientThreadId <- liftIO $ forkIO $ forever $ do receiveMessage clientSock queue socketList liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList STM.putTMVar socketList (ClientComms Nothing clientSock clientThreadId : list) putStrLn "accepted new connection" abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) unless abortCondition $ acceptConnection mainSocket socketList queue st