{-# 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.Loops import Control.Monad.RWS.Strict import Data.Maybe (maybe) 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