{-# 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 qualified Data.Aeson as A import qualified Data.ByteString as B import Data.UUID.V4 import Network.Socket as Net import System.IO import System.Posix.Signals -- internal imports import Library.Types 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 putStrLn "accepting new connections…" (clientSock, _) <- accept mainSocket -- clientHandle <- socketToHandle clientSock ReadWriteMode -- hSetBuffering clientHandle (BlockBuffering Nothing) putStrLn "accepted new connection" -- uuid <- nextRandom -- putStrLn $ "accepting client with uuid " <> show uuid -- sendMessage (AcceptClient uuid) clientHandle liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList STM.putTMVar socketList ((clientSock, Nothing) : list) acceptConnection mainSocket socketList -- | Sends a specified message through given socket to the client sendMessage :: ServerMessage -> Socket -> IO () sendMessage msg sock = do handle <- socketToHandle sock WriteMode hSetBuffering handle (BlockBuffering Nothing) let msgJson = A.encode msg B.hPutStr handle $ B.toStrict msgJson hFlush handle -- hClose handle -- | process incoming messages from clients processMessages :: Game () processMessages = do clientsVar <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar mapM_ (\(clientSocket, _) -> liftIO $ receiveMessage clientSocket ) clients receiveMessage :: Socket -> IO () receiveMessage clientSocket = do clientHandle <- socketToHandle clientSocket ReadMode hSetBuffering clientHandle (BlockBuffering Nothing) message <- hGetContents clientHandle putStr message -- hClose connectionHandle