{-# 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.V4 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…" void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True) disconnectClients clients close sock removeIfExists path -- Raise SIGINT again so it does not get blocked -- raiseSignal sigINT ) Nothing where disconnectClients = mapM_ (\(_, clientSocket) -> do sendMessage ServerQuit clientSocket 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 putStrLn $ "sending: " <> B8.unpack msgJson VS.unsafeWith msgVector (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) -- | receive incoming messages from clients receiveMessages :: Game () receiveMessages = do clientsVar <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar queue <- gets scMessageQueue void $ liftIO $ forkIO $ 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 (\a -> fst a == Nothing) clients let clientSock = snd $ clients !! fromJust clientIdx 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 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 let freshWIzard = newWizard initPos STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) void $ STM.swapTMVar (scPlayers stateContainer) $ Player clientId freshWIzard : currentPlayers let clientSock = fromJust $ lookup (Just clientId) clients sendMessage (ProvideInitialWizard (newWizard initPos)) clientSock _ -> pure () sendUpdates :: Game () sendUpdates = do tileMap <- asks rcMap stateContainer <- get players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) mapM_ (\(player@(Player playerId wizard@(Wizard {..}))) -> do let V2 wr wc = wizardPos subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4] initViewMatrix = M.fromList 9 9 $ map (\(qr, qc) -> M.safeGet qr qc tileMap ) subCoords liftIO $ print initViewMatrix ) players