diff --git a/configuration.yaml b/configuration.yaml index f332f95..1cd7bd3 100644 --- a/configuration.yaml +++ b/configuration.yaml @@ -2,6 +2,6 @@ setSocketPath : "/tmp/wizard.sock" setMapRows : 40 setMapColumns : 40 setSpawnerProbability : 0.01 -setFPS : 30 +setFPS : 1 setClientMaxTimeout : 5 setFramesPerPing : 120 diff --git a/src-client/Main.hs b/src-client/Main.hs index ad2ebb8..fd9bde2 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -15,7 +15,7 @@ import qualified Data.Matrix as M import Graphics.Vty import Graphics.Vty.CrossPlatform -import Network.Socket (close) +import Network.Socket (Socket, close) import Options.Applicative @@ -44,8 +44,7 @@ main = do mockClientState <- STM.newTMVarIO (ClientState undefined False) let mockState = StateContainer undefined mockClientState undefined undefined sendMessage IdRequest sock - receiveMessage sock messageQueue mockState - awaitResponse messageQueue 1 + awaitResponse sock messageQueue mockState 0 clientIdMsg <- head <$> STM.atomically (STM.flushTQueue messageQueue) let clientId = acClientUUID clientIdMsg putStrLn $ "received client UUID: " <> show clientId @@ -57,8 +56,7 @@ main = do sendMessage (ClientMessage clientId ClientRequestWizard) sock -- threadDelay $ 1 * 10 ^ 6 - receiveMessage sock messageQueue mockState - awaitResponse messageQueue 1 + awaitResponse sock messageQueue mockState 1 playerWizard <- head <$> STM.atomically (STM.flushTQueue messageQueue) putStrLn $ "received wizard: " <> show (initWizard playerWizard) @@ -85,7 +83,7 @@ main = do putStrLn "Shutting down client…" showCursor (outputIface vty) shutdown vty - threadDelay (10 ^ 6) + threadDelay (10 ^ 3) putStrLn "Closing connection to server…" close sock putStrLn "bye bye" @@ -112,14 +110,17 @@ welcomeText = mconcat $ map (<> "\n") ] awaitResponse - :: STM.TQueue ServerMessage + :: Socket + -> STM.TQueue ServerMessage + -> StateContainer -> Int -> IO () -awaitResponse _ 10 = error "Tries to communicate with server exceeded" -awaitResponse messageQueue numTries = do +awaitResponsea _ _ _ 10 = error "Tries to communicate with server exceeded" +awaitResponse sock messageQueue mockState numTries = do + receiveMessage sock messageQueue mockState responsePresent <- not <$> STM.atomically (STM.isEmptyTQueue messageQueue) if responsePresent then pure () else do threadDelay $ 10 ^ 6 - awaitResponse messageQueue (succ numTries) + awaitResponse sock messageQueue mockState (succ numTries) diff --git a/src-server/Main.hs b/src-server/Main.hs index 6bf8956..0767f4e 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -54,6 +54,7 @@ main = do putStrLn "starting game…" now <- getCurrentTime sockList <- STM.newTMVarIO [] + queueList <- STM.newTMVarIO [] messageQueue <- STM.newTQueueIO serverState <- STM.newTMVarIO (ServerState False False) emptyPLayers <- STM.newTMVarIO [] @@ -63,7 +64,7 @@ main = do setFramesPerPing setClientMaxTimeout sock - initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList messageQueue + initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList queueList messageQueue (finalState, finalWrite) <- execRWST (do terminateGameOnSigint diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 2c4a85a..a197dee 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -16,6 +16,10 @@ import Control.Monad.IO.Class import Control.Monad.RWS.Strict +import Data.List (find) + +import Data.Maybe (fromJust) + import Network.Socket as Net import System.Posix.Signals @@ -51,12 +55,13 @@ terminateGameOnSigint = do sock <- asks rcMainSocket serverState <- gets scServerState clientList <- gets scClientSockets + queueList <- gets scClientQueues void $ liftIO $ installHandler sigINT (CatchOnce $ do putStrLn "SIGINT caught, terminating…" - clients <- liftIO $ STM.atomically $ STM.readTMVar clientList - disconnectClients clientList clients + queues <- liftIO $ STM.atomically $ STM.readTMVar queueList + disconnectClients clientList queues threadDelay (10 ^ 6) close sock st <- STM.atomically $ STM.readTMVar serverState @@ -68,62 +73,72 @@ terminateGameOnSigint = do -- | Disconnect all connected clients gracefully by announcing the server quitting disconnectClients - :: STM.TMVar [ClientComms] - -> [ClientComms] + :: STM.TMVar [ClientSocket] + -> [ClientQueue] -> IO () -disconnectClients clientList clients = do +disconnectClients clientSockets queues = do putStrLn "server shutting down. Notifying all clients…" mapM_ - (\client -> do + (\queue -> do maybe (pure ()) (\uuid -> do putStrLn $ "notifying client: " <> show uuid - queueMessage ServerQuit uuid clientList - dropClient clientList (ccSocket client) + queueMessage ServerQuit uuid queues + sock <- do + socketList <- STM.atomically $ STM.readTMVar clientSockets + pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList + dropClient clientSockets (csSocket sock) ) - (ccUUID client) + (cqUUID queue) ) - clients + queues -- | Process incoming connection requests processRequests :: Game () processRequests = do mainSocket <- asks rcMainSocket - queue <- gets scMessageQueue + serverQueue <- gets scMessageQueue socketList <- gets scClientSockets + queueList <- gets scClientQueues st <- gets scServerState - void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st + void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queueList serverQueue st where - acceptConnection mainSocket socketList queue st = do + acceptConnection mainSocket socketList queueList serverQueue st = do putStrLn "Ready for new connection requests…" eSock <- try $ accept mainSocket case eSock of Left (_ :: SomeException) -> putStrLn "Main socket vanished!" Right (clientSock, _) -> do - messageQueue <- STM.newTQueueIO + clientQueue <- STM.newTQueueIO sockContainer <- STM.newTMVarIO clientSock - clientWriteThreadId <- liftIO $ forkIO $ forever $ do - receiveMessage sockContainer queue socketList - clientListenThreadId <- liftIO $ forkIO $ forever $ do - sendMessageQueue sockContainer messageQueue + receiverThreadId <- liftIO $ forkIO $ forever $ do + receiveMessage sockContainer serverQueue + senderThreadId <- liftIO $ forkIO $ forever $ do + sendMessageQueue sockContainer clientQueue print clientSock liftIO $ STM.atomically $ do - list <- STM.takeTMVar socketList + slist <- STM.takeTMVar socketList STM.putTMVar socketList - (ClientComms + (ClientSocket Nothing clientSock - messageQueue - clientWriteThreadId - clientListenThreadId - : list + receiverThreadId + senderThreadId + : slist + ) + qlist <- STM.takeTMVar queueList + STM.putTMVar queueList + (ClientQueue + Nothing + clientQueue + : qlist ) putStrLn "accepted new connection" -- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) -- unless abortCondition $ -- acceptConnection mainSocket socketList queue st - acceptConnection mainSocket socketList queue st + acceptConnection mainSocket socketList queueList serverQueue st diff --git a/src-server/Server/Communication/Handler.hs b/src-server/Server/Communication/Handler.hs index 38aaf52..d239f67 100644 --- a/src-server/Server/Communication/Handler.hs +++ b/src-server/Server/Communication/Handler.hs @@ -29,19 +29,20 @@ handleMessage -> IO () handleMessage stateContainer readerContainer msg = do let clientList = scClientSockets stateContainer + queueList <- STM.atomically $ STM.readTMVar $ scClientQueues 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 - clientSock = ccSocket $ clients !! fromJust clientIdx + let clientIdx = findIndex (isNothing . csUUID) clients + clientSock = csSocket $ clients !! fromJust clientIdx newClients = map - (\old@(ClientComms mUUID oldClientSock _ _ _) -> + (\old@(ClientSocket mUUID oldClientSock _ _) -> if oldClientSock == clientSock && isNothing mUUID then old - { ccUUID = Just clientId + { csUUID = Just clientId } else old @@ -49,13 +50,13 @@ handleMessage stateContainer readerContainer msg = do clients void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients putStrLn $ "Accepted Client with UUID " <> show clientId - queueMessage (AcceptClient clientId) clientId clientList + queueMessage (AcceptClient clientId) clientId queueList ClientMessage clientId payload -> case payload of ClientQuit -> do putStrLn $ "client has quit the game: " <> show clientId - let client = find (\a -> ccUUID a == Just clientId) clients - dropClient clientList (ccSocket $ fromJust client) + let client = find (\a -> csUUID a == Just clientId) clients + dropClient clientList (csSocket $ fromJust client) ClientRequestWizard -> do putStrLn "initializing new wizard" let arena = rcMap readerContainer @@ -67,9 +68,8 @@ handleMessage stateContainer readerContainer msg = do currentPlayers <- STM.readTMVar (scPlayers stateContainer) void $ STM.swapTMVar (scPlayers stateContainer) $ Player clientId freshWizard False (now, uuid) : currentPlayers - queueMessage (ProvideInitialWizard freshWizard) clientId clientList + queueMessage (ProvideInitialWizard freshWizard) clientId queueList ClientReady -> do - putStrLn $ "client " <> show clientId <> " is ready!" now <- getCurrentTime STM.atomically $ do currentPlayers <- STM.readTMVar (scPlayers stateContainer) @@ -82,27 +82,27 @@ handleMessage stateContainer readerContainer msg = do , playerLastPong = (now, snd (playerLastPong $ head thisPlayers)) } : otherPlayers - Pong uuid -> do - let mclient = find (\c -> ccUUID c == Just clientId) clients + putStrLn $ "client ready: " <> show clientId + Pong pongUuid -> do + let mclient = find (\c -> csUUID c == Just clientId) clients + players <- STM.atomically $ STM.readTMVar (scPlayers stateContainer) maybe - (putStrLn $ "Who is " <> show uuid <> "?") - (\_ -> do + (putStrLn $ "Unknown client: " <> show clientId) + (const $ 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 + if snd (playerLastPong player) /= pongUuid then - putStrLn $ "Pong ID mismatch from " <> show clientId + putStrLn $ "Pong ID mismatch from: " <> show clientId 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) + { playerLastPong = (now, pongUuid) } void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) sendUpdate stateContainer (rcMap readerContainer) player diff --git a/src-server/Server/Communication/Receive.hs b/src-server/Server/Communication/Receive.hs index 4e3e624..7381e39 100644 --- a/src-server/Server/Communication/Receive.hs +++ b/src-server/Server/Communication/Receive.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Server.Communication.Receive where import Control.Concurrent (threadDelay) @@ -30,43 +31,38 @@ import Server.Types receiveMessage :: STM.TMVar Socket -> STM.TQueue ClientMessage - -> STM.TMVar [ClientComms] -> IO () -receiveMessage sockContainer queue clientList = do +receiveMessage sockContainer queue = do randSleep <- randomRIO (1, 1000) threadDelay randSleep - msock <- STM.atomically $ STM.tryTakeTMVar sockContainer + sock <- STM.atomically $ STM.readTMVar sockContainer let maxBufferLength = 4096 + putStrLn "read socket container for receiving" + mMsg <- do + ptr <- mallocArray maxBufferLength + putStrLn "receiving data" + eBufferLength <- + try $ recvBuf sock ptr maxBufferLength + bufferLength <- case eBufferLength of + Left (e :: IOException) -> do + -- putStrLn ("Socket vanished, cleaning up after " <> show e) + -- dropClient clientList sock + pure 0 + Right len -> pure len + free ptr + msg <- B.pack <$> peekArray bufferLength ptr + putStrLn $ "received data: " <> show msg + if bufferLength > 0 && msg /= "" + then do + putStrLn $ "received message: " <> show msg + pure (A.decode' $ B8.fromStrict msg :: Maybe ClientMessage) + else + pure Nothing maybe (pure ()) - (\sock -> do - putStrLn "took socket container for receiving" - mMsg <- do - ptr <- mallocArray maxBufferLength - eBufferLength <- - try $ recvBuf sock ptr maxBufferLength - bufferLength <- case eBufferLength of - Left (e :: IOException) -> do - -- putStrLn ("Socket vanished, cleaning up after " <> show e) - -- 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 - print msg - liftIO $ STM.atomically $ STM.writeTQueue queue msg - -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) - ) - mMsg - STM.atomically $ STM.putTMVar sockContainer sock + (\msg -> do + print msg + liftIO $ STM.atomically $ STM.writeTQueue queue msg + -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) ) - msock + mMsg diff --git a/src-server/Server/Communication/Send.hs b/src-server/Server/Communication/Send.hs index cb0a0b0..29afd30 100644 --- a/src-server/Server/Communication/Send.hs +++ b/src-server/Server/Communication/Send.hs @@ -47,50 +47,44 @@ import Server.Types queueMessage :: ServerMessage -> UUID - -> STM.TMVar [ClientComms] + -> [ClientQueue] -> IO () -queueMessage msg uuid clientList = do - clients <- STM.atomically $ STM.readTMVar clientList - let mQueue = ccQueue <$> find (\client -> ccUUID client == Just uuid) clients +queueMessage msg uuid queueList = do + putStrLn $ "queueing message \"" <> show msg <> "\" for client " <> show uuid <> " …" + let mQueue = cqQueue <$> find (\client -> cqUUID client == Just uuid) queueList maybe - (putStrLn $ "unknown client UUID: " <> show uuid) + (putStrLn $ "no queue found for client: " <> show uuid) (\queue -> STM.atomically $ STM.writeTQueue queue msg ) mQueue + putStrLn "message queued!" sendMessageQueue :: STM.TMVar Socket -> STM.TQueue ServerMessage -> IO () sendMessageQueue sockContainer queue = do - randSleep <- randomRIO (1, 1000) - threadDelay randSleep - msock <- STM.atomically $ STM.tryTakeTMVar sockContainer - maybe - (pure ()) - (\sock -> do - putStrLn "took socket container for sending" - msgs <- STM.atomically $ STM.flushTQueue queue - mapM_ - (\msg -> do - let msgJson = A.encode msg - msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>')) - VS.unsafeWith - msgVector - (\ptr -> do - eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector) - case eResult of - Left (e :: IOException) -> - putStrLn $ "can't reach client after " <> show e - Right _ -> - pure () - ) + msgs <- STM.atomically $ STM.flushTQueue queue + mapM_ + (\msg -> do + sock <- STM.atomically $ STM.readTMVar sockContainer + putStrLn "read socket container for sending" + putStrLn $ "sending message: " <> show msg + let msgJson = A.encode msg + msgVector = VS.fromList $ B.unpack $ B.toStrict ('<' `B8.cons` (msgJson `B8.snoc` '>')) + VS.unsafeWith + msgVector + (\ptr -> do + eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector) + case eResult of + Left (e :: IOException) -> + putStrLn $ "can't reach client after " <> show e + Right _ -> + pure () ) - msgs - STM.atomically $ STM.putTMVar sockContainer sock ) - msock + msgs sendPings :: Game () sendPings = do @@ -100,54 +94,59 @@ sendPings = do fps <- asks rcFPS stateContainer <- get players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer) - sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets 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 $ do - putStrLn $ "dropping client because of timeout: " <> show plId - dropClient (scClientSockets stateContainer) (fromJust clientSock) - put stateContainer - else do + -- let clientSock = ccSocket <$> find (\c -> ccUUID c == Just plId) sockets + -- when (isJust clientSock) $ + -- if timeDiff > realToFrac maxTimeout + -- then do + -- liftIO $ do + -- putStrLn $ "dropping client because of timeout: " <> show plId + -- dropClient (scClientSockets stateContainer) (fromJust clientSock) + -- put stateContainer + -- else do random <- liftIO nextRandom let newPong = (now, random) - liftIO $ queueMessage - ( Ping random - ) - plId - (scClientSockets stateContainer) + liftIO $ do + queues <- STM.atomically $ STM.readTMVar (scClientQueues stateContainer) + queueMessage + ( Ping random + ) + plId + queues let newPlayer = player { playerLastPong = newPong } otherPlayers = filter (\a -> playerId a /= plId) players - liftIO $ void $ STM.atomically $ - STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers) + liftIO $ do + void $ STM.atomically $ + STM.swapTMVar (scPlayers stateContainer) (newPlayer : otherPlayers) + putStrLn "ping!" ) players put stateContainer -- | Drops the client from internal management and closes its socket, if still present. dropClient - :: STM.TMVar [ClientComms] + :: STM.TMVar [ClientSocket] -> 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 + let mclient = find (\client -> csSocket client == sock) clients + let reducedClients = filter (\client -> csSocket client /= sock) clients void $ STM.swapTMVar clientList reducedClients pure mclient maybe (putStrLn $ "closing unknown socket: " <> show sock) (\client -> do - putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ ccUUID client) - killThread (ccListener client) + putStrLn $ "dropping client because of closed socket: " <> show (fromJust $ csUUID client) + killThread (csSender client) + killThread (csReceiver client) ) mClient close sock @@ -158,11 +157,11 @@ sendUpdate -> Player -> IO () sendUpdate stateContainer tileMap player = do - slice <- buildSlice player + let slice = buildSlice player sendSlice slice player where - buildSlice :: Player -> IO MapSlice - buildSlice (Player _ (Wizard {..}) _ _) = do + buildSlice :: Player -> MapSlice + buildSlice (Player _ (Wizard {..}) _ _) = let V2 wr wc = wizardPos subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4] leftBound = wizardRot + (pi / 4) @@ -185,9 +184,12 @@ sendUpdate stateContainer tileMap player = do Nothing ) subCoords - pure (MapSlice initViewMatrix []) + in + MapSlice initViewMatrix [] sendSlice :: MapSlice -> Player -> IO () sendSlice slice (Player playerId wizard _ _) = do let msg = TickUpdate slice wizard -- print slice - liftIO $ queueMessage msg playerId (scClientSockets stateContainer) + liftIO $ do + queues <- STM.atomically $ STM.readTMVar $ scClientQueues stateContainer + queueMessage msg playerId queues diff --git a/src-server/Server/Game.hs b/src-server/Server/Game.hs index 63fd1ac..7e0e1a4 100644 --- a/src-server/Server/Game.hs +++ b/src-server/Server/Game.hs @@ -36,13 +36,13 @@ runGame = do let delta = realToFrac $ diffUTCTime now before -- liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> " \r" handleMessages - updateSpawners delta - updateWizards delta - modify' - (\s -> s - { scServerLastTick = now - } - ) + -- updateSpawners delta + -- updateWizards delta + -- modify' + -- (\s -> s + -- { scServerLastTick = now + -- } + -- ) fps <- asks rcFPS sendPings let remainingTime = recip (fromIntegral fps) - delta @@ -50,4 +50,3 @@ runGame = do liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6 ) liftIO $ threadDelay (10 ^ 6) - -- liftIO $ killThread recvThread diff --git a/src-server/Server/Game/Update.hs b/src-server/Server/Game/Update.hs index 0e65454..42dc123 100644 --- a/src-server/Server/Game/Update.hs +++ b/src-server/Server/Game/Update.hs @@ -16,7 +16,7 @@ import Server.Types updateSpawners :: Float -> Game () updateSpawners dt = - modify' (\sc@(StateContainer spawners _ _ _ _ _) -> + modify' (\sc@(StateContainer spawners _ _ _ _ _ _) -> let newSpawners = map (\spawner -> do let newTTL = spawnerReloadTTL spawner - dt diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 6a35840..dbce0b5 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -63,16 +63,22 @@ data StateContainer = StateContainer , scPlayers :: STM.TMVar [Player] , scServerState :: STM.TMVar ServerState , scServerLastTick :: UTCTime - , scClientSockets :: STM.TMVar [ClientComms] + , scClientSockets :: STM.TMVar [ClientSocket] + , scClientQueues :: STM.TMVar [ClientQueue] , scMessageQueue :: STM.TQueue ClientMessage } -data ClientComms = ClientComms - { ccUUID :: Maybe UUID - , ccSocket :: Socket - , ccQueue :: STM.TQueue ServerMessage - , ccWriter :: ThreadId - , ccListener :: ThreadId +data ClientSocket = ClientSocket + { csUUID :: Maybe UUID + , csSocket :: Socket + , csSender :: ThreadId + , csReceiver :: ThreadId + } + deriving (Eq) + +data ClientQueue = ClientQueue + { cqUUID :: Maybe UUID + , cqQueue :: STM.TQueue ServerMessage } deriving (Eq)