{-# 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 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 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 clientList <- gets scClientSockets clients <- liftIO $ STM.atomically $ STM.readTMVar clientList serverState <- gets scServerState void $ liftIO $ installHandler sigINT (CatchOnce $ do putStrLn "SIGINT caught, terminating…" disconnectClients clientList 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 :: STM.TMVar [(Maybe UUID, Socket)] -> [(Maybe UUID, Socket)] -> IO () disconnectClients clientList = mapM_ (\client@(_, clientSocket) -> do sendMessage ServerQuit clientSocket dropClient clientList client ) dropClient :: STM.TMVar [(Maybe UUID, Socket)] -> (Maybe UUID, Socket) -> IO () dropClient clientList (uuid, clientSocket) = do STM.atomically $ do clients <- STM.readTMVar clientList let reducedClients = filter ((/= uuid) . fst) clients void $ STM.swapTMVar clientList reducedClients putStrLn $ "dropping client " <> show uuid 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 emptyState <- liftIO $ STM.atomically $ STM.isEmptyTQueue queue unless emptyState $ do 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 uuid <- nextRandom let freshWizard = newWizard initPos STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) void $ STM.swapTMVar (scPlayers stateContainer) $ Player clientId freshWizard False (now, uuid) : 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 Pong uuid -> do let client = fromJust (lookup (Just clientId) clients) player <- STM.atomically $ do players <- STM.readTMVar (scPlayers stateContainer) pure $ head $ filter (\p -> playerId p == clientId) players -- if snd (playerLastPong player) /= uuid -- then do -- putStrLn $ "dropping client " <> show clientId -- dropClient clientList (Just clientId, client) -- else do now <- getCurrentTime STM.atomically$ do players <- STM.readTMVar (scPlayers stateContainer) let otherPlayers = filter (\a -> playerId a /= playerId player) players modPlayer = player { playerLastPong = (now, uuid) } void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : 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@(Player plId (Wizard {}) readiness (lastPongTime, _)) -> do let timeDiff = realToFrac $ diffUTCTime now lastPongTime when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do let clientSock = lookup (Just plId) sockets when (isJust clientSock) $ if timeDiff > realToFrac maxTimeout then do liftIO $ dropClient (scClientSockets stateContainer) (Just plId, fromJust clientSock) put stateContainer else do random <- liftIO nextRandom let newPong = (lastPongTime, random) liftIO $ sendMessage ( Ping random ) (fromJust clientSock) let newPlayer = player { playerLastPong = newPong } otherPlayers = filter (\a -> playerId a /= plId) players liftIO $ void $ STM.atomically $ STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers) put stateContainer ) players