diff --git a/src-client/Client/Communication.hs b/src-client/Client/Communication.hs index cc19823..cf3076e 100644 --- a/src-client/Client/Communication.hs +++ b/src-client/Client/Communication.hs @@ -20,12 +20,8 @@ import Data.IORef import Data.UUID -import qualified Data.Vector.Storable as VS - import Foreign hiding (void) -import Graphics.Vty as Vty - import Network.Socket import System.Posix.Signals @@ -46,11 +42,10 @@ connectSocket path = do -- | Sends a specified message through given socket to the server sendMessage - :: StateContainer - -> ClientMessage + :: ClientMessage -> Socket -> IO () -sendMessage st msg sock = do +sendMessage msg sock = do let msgJson = A.encode msg msgList = B.unpack $ B.toStrict msgJson ptr <- newArray msgList @@ -79,9 +74,7 @@ handleMessage ServerQuit = do handleMessage (Ping id') = do cid <- asks rcClientUUID sock <- asks rcSocket - st <- get liftIO $ sendMessage - st ( ClientMessage cid (Pong id') @@ -106,12 +99,7 @@ gracefulExit -> IO () gracefulExit st reason = do liftIO $ putStrLn reason - let stateCont = scClientState st - liftIO $ STM.atomically $ do - stateContainer <- STM.readTMVar stateCont - void $ STM.swapTMVar stateCont $ stateContainer - { clientStop = True - } + writeIORef (scStopper st) True receiveMessage :: Socket @@ -148,10 +136,12 @@ terminateGameOnSigint :: IORef Bool -> Game () terminateGameOnSigint stopper = do + rc <- ask void $ liftIO $ installHandler keyboardSignal (CatchOnce $ do putStrLn "receiveMessage: SIGINT caught, terminating…" + liftIO $ partingMessage (rcClientUUID rc) (rcSocket rc) atomicWriteIORef stopper True -- Vty.shutdown (clientVty currentState) -- Raise SIGINT again so it does not get blocked @@ -160,10 +150,9 @@ terminateGameOnSigint stopper = do Nothing partingMessage - :: StateContainer - -> UUID + :: UUID -> Socket -> IO () -partingMessage st clientId sock = do - sendMessage st (ClientMessage clientId ClientQuit) sock - -- close sock +partingMessage clientId sock = do + putStrLn "sending parting message to server…" + sendMessage (ClientMessage clientId ClientQuit) sock diff --git a/src-client/Client/Game.hs b/src-client/Client/Game.hs index f4b87b9..7d380b2 100644 --- a/src-client/Client/Game.hs +++ b/src-client/Client/Game.hs @@ -1,16 +1,10 @@ module Client.Game where -import Control.Concurrent - -import qualified Control.Concurrent.STM as STM - -import Control.Monad - import Control.Monad.Loops import Control.Monad.RWS -import Data.IORef (IORef, readIORef) +import Data.IORef (readIORef) import Graphics.Vty @@ -23,23 +17,21 @@ import Client.Types import Library.Types runGame - :: IORef Bool - -> Game () -runGame stopper = do + :: Game () +runGame = do sock <- asks rcSocket queue <- asks rcQueue clientId <- asks rcClientUUID st <- get -- recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st - liftIO $ sendMessage st(ClientMessage clientId ClientReady) sock + liftIO $ sendMessage (ClientMessage clientId ClientReady) sock whileM_ - (liftIO (not <$> readIORef stopper)) + (liftIO (not <$> readIORef (scStopper st))) (do liftIO $ receiveMessage sock queue st handleMessages -- draw ) - liftIO $ partingMessage st clientId sock -- liftIO $ killThread recvThread handleEvent diff --git a/src-client/Client/Types.hs b/src-client/Client/Types.hs index 84aa9fd..cde7cb9 100644 --- a/src-client/Client/Types.hs +++ b/src-client/Client/Types.hs @@ -6,6 +6,8 @@ import Control.Exception (Exception) import Control.Monad.RWS +import Data.IORef (IORef) + import Data.UUID import Network.Socket @@ -37,6 +39,7 @@ data StateContainer = StateContainer { scWizard :: Wizard , scClientState :: STM.TMVar ClientState , scMapSlice :: MapSlice + , scStopper :: IORef Bool } type Game = RWST ReaderContainer String StateContainer IO diff --git a/src-client/Main.hs b/src-client/Main.hs index 92e8daf..b349c09 100644 --- a/src-client/Main.hs +++ b/src-client/Main.hs @@ -14,8 +14,6 @@ import qualified Data.Matrix as M import Graphics.Vty -import Network.Socket (close) - import Options.Applicative -- internal imports @@ -39,9 +37,9 @@ main = do -- threadDelay $ 1 * 10 ^ 6 - mockClientState <- STM.newTMVarIO (ClientState undefined False False) - let mockState = StateContainer undefined mockClientState undefined - sendMessage mockState (IdRequest) sock + mockClientState <- STM.newTMVarIO (ClientState undefined False) + let mockState = StateContainer undefined mockClientState undefined undefined + sendMessage IdRequest sock receiveMessage sock queue mockState awaitResponse queue 1 clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue) @@ -53,7 +51,7 @@ main = do threadDelay $ 5 * 10 ^ 6 - sendMessage mockState (ClientMessage clientId ClientRequestWizard) sock + sendMessage (ClientMessage clientId ClientRequestWizard) sock -- threadDelay $ 1 * 10 ^ 6 receiveMessage sock queue mockState awaitResponse queue 1 @@ -67,17 +65,17 @@ main = do -- shut down graphical interface for now -- shutdown vty - clientState <- STM.newTMVarIO (ClientState undefined False False) + stopper <- newIORef False + clientState <- STM.newTMVarIO (ClientState undefined False) let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) [] let initRead = ReaderContainer sock clientId queue - initState = StateContainer (initWizard playerWizard) clientState initSlice + initState = StateContainer (initWizard playerWizard) clientState initSlice stopper -- putStrLn "sending quit message" -- sendMessage (ClientMessage clientId ClientQuit) sock - stopper <- newIORef False void $ execRWST (do terminateGameOnSigint stopper - runGame stopper + runGame ) initRead initState diff --git a/src-lib/Library/Types/Map.hs b/src-lib/Library/Types/Map.hs index 174318a..81fbc6c 100644 --- a/src-lib/Library/Types/Map.hs +++ b/src-lib/Library/Types/Map.hs @@ -16,7 +16,6 @@ import Data.Aeson (ToJSON, FromJSON) data ClientState = ClientState { clientVty :: Vty -- ^ Context object for graphics , clientGameOver :: Bool -- ^ client game over (contestant died) - , clientStop :: Bool -- ^ client shutdown } -- | Type synonym for the Map. Translates to a Matrix of 'Tile's diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index e14105a..6733bd0 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -62,13 +62,13 @@ terminateGameOnSigint :: Game () terminateGameOnSigint = do sock <- asks rcMainSocket - clientList <- gets scClientSockets - clients <- liftIO $ STM.atomically $ STM.readTMVar clientList serverState <- gets scServerState + clientList <- gets scClientSockets void $ liftIO $ installHandler sigINT (CatchOnce $ do putStrLn "SIGINT caught, terminating…" + clients <- liftIO $ STM.atomically $ STM.readTMVar clientList disconnectClients clientList clients close sock st <- STM.atomically $ STM.readTMVar serverState @@ -83,16 +83,19 @@ 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) - ) +disconnectClients clientList clients = do + putStrLn "server shutting down. Notifying all clients…" + mapM_ + (\client -> do + maybe + (pure ()) + (\uuid -> do + sendMessage ServerQuit uuid clientList + dropClient clientList (ccSocket client) + ) + (ccUUID client) + ) + clients -- | Drops the client from internal management and closes its socket, if still present. dropClient @@ -126,8 +129,8 @@ processRequests = do where acceptConnection mainSocket socketList queue st = do putStrLn "Ready for new connection requests…" - esock <- try $ accept mainSocket - case esock of + eSock <- try $ accept mainSocket + case eSock of Left (_ :: SomeException) -> putStrLn "Main socket vanished!" Right (clientSock, _) -> do @@ -135,7 +138,7 @@ processRequests = do receiveMessage clientSock queue socketList liftIO $ STM.atomically $ do list <- STM.takeTMVar socketList - STM.putTMVar socketList ((ClientComms Nothing clientSock clientThreadId) : list) + STM.putTMVar socketList (ClientComms Nothing clientSock clientThreadId : list) putStrLn "accepted new connection" abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st) unless abortCondition $ @@ -150,7 +153,7 @@ sendMessage -> IO () sendMessage msg uuid clientList = do clients <- STM.atomically $ STM.readTMVar clientList - let msock = ccSocket <$> find (\client -> ccUUID client == Just uuid) clients + 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 @@ -159,9 +162,16 @@ sendMessage msg uuid clientList = do (\sock -> VS.unsafeWith msgVector - (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) + (\ptr -> do + eResult <- try $ void $ sendBuf sock ptr (VS.length msgVector) + case eResult of + Left (_ :: IOException) -> + putStrLn $ "cant reach client " <> show uuid + Right _ -> + pure () + ) ) - msock + mSock -- | handle received messages handleMessages :: Game () @@ -177,7 +187,6 @@ handleMessages = do pure [] else STM.flushTQueue queue - unless (null msgs) $ putStrLn "GET" void $ do mapM_ (handleMessage serverState readerContainer) @@ -191,11 +200,11 @@ receiveMessage -> IO () receiveMessage sock queue clientList = do let maxBufferLength = 4096 - mmsg <- do + mMsg <- do ptr <- mallocArray maxBufferLength - ebufferLength <- + eBufferLength <- try $ recvBuf sock ptr maxBufferLength - bufferLength <- case ebufferLength of + bufferLength <- case eBufferLength of Left (_ :: IOException) -> do putStrLn "Socket vanished, cleaning up…" dropClient clientList sock @@ -212,11 +221,10 @@ receiveMessage sock queue clientList = do maybe (pure ()) (\msg -> do - putStrLn "PUT" liftIO $ STM.atomically $ STM.writeTQueue queue msg -- when (msg == IdRequest) (threadDelay $ 10 ^ 3) ) - mmsg + mMsg -- | function for translating 'ClientMessage's into server actions handleMessage @@ -232,10 +240,10 @@ handleMessage stateContainer readerContainer msg = do 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 + clientSock = ccSocket $ clients !! fromJust clientIdx + newClients = map + (\old@(ClientComms mUUID oldClientSock _) -> + if oldClientSock == clientSock && isNothing mUUID then old { ccUUID = Just clientId @@ -250,15 +258,9 @@ handleMessage stateContainer readerContainer msg = do 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) + putStrLn $ "client " <> show clientId <> " has quit the game" + let client = find (\a -> ccUUID a == Just clientId) clients + dropClient clientList (ccSocket $ fromJust client) ClientRequestWizard -> do putStrLn "initializing new wizard" let arena = rcMap readerContainer @@ -273,28 +275,32 @@ handleMessage stateContainer readerContainer msg = do sendMessage (ProvideInitialWizard freshWizard) clientId clientList ClientReady -> do putStrLn $ "client " <> show clientId <> " is ready!" + now <- getCurrentTime 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 + (head thisPlayers) + { playerReady = True + , playerLastPong = (now, snd (playerLastPong $ head thisPlayers)) + } + : 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 + (\_ -> 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) + then + putStrLn $ "Pong ID mismatch from " <> show clientId else do now <- getCurrentTime STM.atomically$ do @@ -305,7 +311,7 @@ handleMessage stateContainer readerContainer msg = do } void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) ) - mplayer + mPlayer ) mclient @@ -330,7 +336,7 @@ sendPings = do put stateContainer else do random <- liftIO nextRandom - let newPong = (now, random) + let newPong = (lastPongTime, random) liftIO $ sendMessage ( Ping random )