{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} 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 qualified Data.Matrix as M import Data.Maybe import Data.UUID hiding (null) import Data.UUID.V4 import Data.Time import qualified Data.Vector.Storable as VS import Foreign hiding (void) import Linear 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 :: FilePath -> Game () terminateGameOnSigint path = do sock <- asks rcMainSocket clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets serverState <- gets scServerState void $ liftIO $ installHandler sigINT (CatchOnce $ do putStrLn "SIGINT caught, terminating…" disconnectClients clients close sock removeIfExists path void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True) -- Raise SIGINT again so it does not get blocked -- raiseSignal sigINT ) Nothing disconnectClients :: [(Maybe UUID, Socket)] -> IO () disconnectClients = mapM_ (\(_, clientSocket) -> do sendMessage ServerQuit clientSocket close clientSocket ) timeoutClients :: [(Maybe UUID, Socket)] -> IO () timeoutClients = 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 $ ('<' `B8.cons` (msgJson `B8.snoc` '>')) -- putStrLn $ "sending: " <> B8.unpack msgJson VS.unsafeWith msgVector (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) -- | receive incoming messages from clients receiveMessages :: STM.TMVar [(Maybe UUID, Socket)] -> STM.TQueue ClientMessage -> IO () receiveMessages clientsVar queue = do clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar mapM_ (\(_, clientSocket) -> do receiveMessage clientSocket queue ) clients -- | handle received messages handleMessages :: Game () handleMessages = do queue <- gets scMessageQueue serverState <- get readerContainer <- ask msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue void $ liftIO $ do mapM_ (handleMessage serverState readerContainer) msgs -- | receive a 'ClientMessage' receiveMessage :: Socket -> STM.TQueue ClientMessage -> IO () receiveMessage sock queue = do let maxBufferLength = 4096 mmsg <- 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 liftIO $ STM.atomically $ STM.writeTQueue queue msg -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) ) mmsg -- | function for translating 'ClientMessage's into server actions handleMessage :: StateContainer -> ReaderContainer -> ClientMessage -> IO () handleMessage stateContainer readerContainer msg = do let clientList = scClientSockets stateContainer clients <- liftIO $ STM.atomically $ STM.readTMVar clientList putStrLn $ "Handling following: " <> show msg case msg of IdRequest -> do clientId <- nextRandom let clientIdx = findIndex (isNothing . fst) clients let clientSock = snd $ clients !! fromJust clientIdx let newClients = map (\old@(muuid, oldClientSock) -> if oldClientSock == clientSock && isNothing muuid then (Just clientId, clientSock) else old ) clients void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients putStrLn $ "Accepted Client with UUID " <> show clientId sendMessage (AcceptClient clientId) clientSock ClientMessage clientId payload -> case payload of ClientQuit -> do putStrLn $ "removing client " <> show clientId let newClients = filter (\a -> fst a /= Just clientId) clients STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers void $ STM.swapTMVar (scPlayers stateContainer) newPlayers void $ STM.swapTMVar clientList newClients ClientRequestWizard -> do putStrLn "initializing new wizard" let arena = rcMap readerContainer initPos <- rollInitPosition arena now <- liftIO getCurrentTime let freshWizard = newWizard initPos STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) void $ STM.swapTMVar (scPlayers stateContainer) $ Player clientId freshWizard False now : currentPlayers let clientSock = fromJust $ lookup (Just clientId) clients sendMessage (ProvideInitialWizard freshWizard) clientSock ClientReady -> do putStrLn $ "client " <> show clientId <> " is ready!" STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) let (thisPlayers, otherPlayers) = partition (\p -> playerId p == clientId) currentPlayers unless (null thisPlayers) $ void $ STM.swapTMVar (scPlayers stateContainer) $ (head thisPlayers) {playerReady = True} : otherPlayers _ -> pure () sendPings :: Game () sendPings = do now <- liftIO getCurrentTime maxTimeout <- asks rcClientMaxTimeout framesPerPing <- asks rcFramesPerPing fps <- asks rcFPS stateContainer <- get players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer) mapM_ (\(Player playerId (Wizard {}) readiness lastPong) -> do let timeDiff = realToFrac $ diffUTCTime now lastPong when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do let clientSock = fromJust (lookup (Just playerId) sockets) if timeDiff > realToFrac maxTimeout then liftIO $ disconnectClients [(Just playerId, clientSock)] else do random <- liftIO nextRandom liftIO $ sendMessage ( Ping random ) clientSock ) players