{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Server.Communication where import Control.Concurrent import qualified Control.Concurrent.STM as STM import Control.Exception.Base 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) ) Nothing -- | Disconnect all connected clients gracefully by announcing the server quitting disconnectClients :: STM.TMVar [(Maybe UUID, Socket)] -> [(Maybe UUID, Socket)] -> IO () disconnectClients clientList = mapM_ (\client@(muuid, _) -> do maybe (pure ()) (\uuid -> do sendMessage ServerQuit uuid clientList dropClient clientList uuid ) muuid ) -- | Drops the client from internal management and closes its socket, if still present. dropClient :: STM.TMVar [(Maybe UUID, Socket)] -> UUID -> IO () dropClient clientList uuid = do msock <- STM.atomically $ do clients <- STM.readTMVar clientList let msock = lookup (Just uuid) clients let reducedClients = filter ((/= Just uuid) . fst) clients void $ STM.swapTMVar clientList reducedClients pure msock putStrLn $ "dropping client " <> show uuid maybe (pure ()) close msock -- | 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 -> UUID -> STM.TMVar [(Maybe UUID, Socket)] -> IO () sendMessage msg uuid clientList = do clients <- STM.atomically $ STM.readTMVar clientList let msock = lookup (Just uuid) clients msgJson = A.encode msg msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>')) -- putStrLn $ "sending: " <> B8.unpack msgJson maybe (dropClient clientList uuid) (\sock -> VS.unsafeWith msgVector (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) ) msock -- | 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_ (\(muuid, clientSocket) -> do receiveMessage clientSocket queue muuid clientsVar ) 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 -> Maybe UUID -> STM.TMVar [(Maybe UUID, Socket)] -> IO () receiveMessage sock queue muuid clientList = do let maxBufferLength = 4096 mmsg <- do ptr <- mallocArray maxBufferLength ebufferLength <- try $ recvBuf sock ptr maxBufferLength bufferLength <- case ebufferLength of Left (_ :: IOException) -> do putStrLn "Socket vanished, cleaning up…" maybe (pure ()) (dropClient clientList) muuid pure 0 Right len -> pure len 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) clientId clientList 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 sendMessage (ProvideInitialWizard freshWizard) clientId clientList 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) plId put stateContainer else do random <- liftIO nextRandom let newPong = (lastPongTime, random) liftIO $ sendMessage ( Ping random ) plId (scClientSockets stateContainer) 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