{-# LANGUAGE OverloadedStrings #-} 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) -- removeIfExists 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 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 st <- STM.atomically $ STM.readTMVar serverState void $ STM.atomically $ STM.swapTMVar serverState $ st { serverStop = True } ) Nothing -- | Disconnect all connected clients gracefully by announcing the server quitting disconnectClients :: STM.TMVar [ClientComms] -> [ClientComms] -> IO () disconnectClients clientList = mapM_ (\client -> do maybe (pure ()) (\uuid -> do sendMessage ServerQuit uuid clientList dropClient clientList (ccSocket client) ) (ccUUID client) ) -- | Drops the client from internal management and closes its socket, if still present. dropClient :: STM.TMVar [ClientComms] -> Socket -> IO () dropClient clientList sock = do mclient <- STM.atomically $ do clients <- STM.readTMVar clientList let mclient = find (\client -> ccSocket client == sock) clients let reducedClients = filter (\client -> ccSocket client /= sock) clients void $ STM.swapTMVar clientList reducedClients pure mclient maybe (putStrLn $ "closing unknown socket: " <> show sock) (\client -> do putStrLn $ "dropping client: " <> show (ccUUID client) killThread (ccListener client) ) mclient close sock -- | Process incoming connection requests processRequests :: Game () processRequests = do mainSocket <- asks rcMainSocket queue <- gets scMessageQueue socketList <- gets scClientSockets st <- gets scServerState void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st where acceptConnection mainSocket socketList queue st = do putStrLn "Ready for new connection requests…" esock <- try $ accept mainSocket case esock of Left (_ :: SomeException) -> putStrLn "Main socket vanished!" Right (clientSock, _) -> do clientThreadId <- liftIO $ forkIO $ forever $ do receiveMessage clientSock queue socketList liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list) putStrLn "accepted new connection" abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) unless abortCondition $ acceptConnection mainSocket socketList queue st -- | Sends a specified message through given socket to the client sendMessage :: ServerMessage -> UUID -> STM.TMVar [ClientComms] -> IO () sendMessage msg uuid clientList = do clients <- STM.atomically $ STM.readTMVar clientList let msock = ccSocket <$> find (\client -> ccUUID client == 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 (putStrLn $ "unknown client UUID: " <> show uuid) (\sock -> VS.unsafeWith msgVector (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) ) msock -- | handle received messages handleMessages :: Game () handleMessages = do queue <- gets scMessageQueue serverState <- get readerContainer <- ask liftIO $ do msgs <- STM.atomically $ do emptyState <- STM.isEmptyTQueue queue if emptyState then pure [] else STM.flushTQueue queue unless (null msgs) $ putStrLn "GET" void $ do mapM_ (handleMessage serverState readerContainer) msgs -- | receive a 'ClientMessage' receiveMessage :: Socket -> STM.TQueue ClientMessage -> STM.TMVar [ClientComms] -> IO () receiveMessage sock queue 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…" dropClient clientList sock 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 putStrLn "PUT" 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: " <> show msg case msg of IdRequest -> do clientId <- nextRandom let clientIdx = findIndex (isNothing . ccUUID) clients let clientSock = ccSocket $ clients !! fromJust clientIdx let newClients = map (\old@(ClientComms muuid oldClientSock _) -> if oldClientSock == clientSock && isNothing muuid then old { ccUUID = Just clientId } 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 -> ccUUID a /= Just clientId) clients client = find (\a -> ccUUID 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 close (ccSocket $ fromJust client) 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 mclient = find (\c -> ccUUID c == Just clientId) clients maybe (putStrLn $ "Who is " <> show uuid <> "?") (\client -> do mplayer <- STM.atomically $ do players <- STM.readTMVar (scPlayers stateContainer) pure $ find (\p -> playerId p == clientId) players maybe (pure ()) (\player -> if snd (playerLastPong player) /= uuid then do putStrLn $ "dropping client " <> show clientId dropClient clientList (ccSocket 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) ) mplayer ) mclient 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 :: Float when (readiness && timeDiff > (fromIntegral framesPerPing * recip (fromIntegral fps))) $ do let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets when (isJust clientSock) $ if timeDiff > realToFrac maxTimeout then do liftIO $ dropClient (scClientSockets stateContainer) (fromJust clientSock) put stateContainer else do random <- liftIO nextRandom let newPong = (now, 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