{-# 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 qualified Data.ByteString.Lazy.Char8 as B8 import Data.List import Data.Maybe import Data.UUID.V4 import qualified Data.Vector.Storable as VS import Foreign hiding (void) import Network.Socket as Net 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) -> do 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 liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList STM.putTMVar socketList ((Nothing, clientSock) : list) putStrLn "accepted new connection" acceptConnection mainSocket socketList -- | Sends a specified message through given socket to the client sendMessage :: ServerMessage -> Socket -> IO () sendMessage msg sock = do let msgJson = A.encode msg msgVector = VS.fromList $ B.unpack $ B.toStrict msgJson VS.unsafeWith msgVector (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) -- | process incoming messages from clients processMessages :: Game () processMessages = do clientsVar <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar mapM_ (\(uuid, clientSocket) -> do receiveMessage clientSocket handleMessage ) clients -- | receive a 'ClientMessage' receiveMessage :: Socket -> Game () receiveMessage sock = do let maxBufferLength = 4096 mmsg <- liftIO $ do ptr <- mallocArray maxBufferLength bufferLength <- recvBuf sock ptr maxBufferLength msg <- B.pack <$> peekArray bufferLength ptr let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage free ptr if bufferLength > 0 then pure mJsonMsg else pure Nothing maybe (pure ()) (\msg -> do queue <- gets scMessageQueue liftIO $ STM.atomically $ STM.writeTQueue queue msg ) mmsg -- | function for translating 'ClientMessage's into server actions handleMessage :: Game () handleMessage = do queue <- gets scMessageQueue msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue clientList <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientList mapM_ (\msg -> liftIO $ do putStrLn "Handling following:" print msg case msg of IdRequest -> do clientId <- nextRandom let clientIdx = findIndex (\a -> fst a == Nothing) clients let clientSock = snd $ clients !! fromJust clientIdx sendMessage (AcceptClient clientId) clientSock putStrLn $ "Accepted Client with UUID " <> show clientId let newClients = map (\old@(muuid, oldClientSock) -> if oldClientSock == clientSock && muuid == Nothing then (Just clientId, clientSock) else old ) clients void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients _ -> pure () ) msgs