From be888101a0f1be359fad212d6b3884b90a9615ce Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 29 Mar 2024 10:34:15 +0100 Subject: [PATCH] introduce proper exception handling --- src-server/Main.hs | 3 ++ src-server/Server/Communication.hs | 82 +++++++++++++++++++++--------- 2 files changed, 60 insertions(+), 25 deletions(-) diff --git a/src-server/Main.hs b/src-server/Main.hs index cdeb50c..5637cd0 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Concurrent (threadDelay) + import qualified Control.Concurrent.STM as STM import Control.Monad.RWS.Strict @@ -69,6 +71,7 @@ main = do initRead initState -- removeIfExists setSocketPath + threadDelay 1000 putStrLn "bye bye" where opts = info (options <**> helper) diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs index 48adb66..8bcd3fb 100644 --- a/src-server/Server/Communication.hs +++ b/src-server/Server/Communication.hs @@ -6,6 +6,8 @@ import Control.Concurrent import qualified Control.Concurrent.STM as STM +import Control.Exception.Base + import Control.Monad import Control.Monad.IO.Class @@ -73,32 +75,42 @@ terminateGameOnSigint path = do 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 +-- | Disconnect all connected clients gracefully by announcing the server quitting disconnectClients :: STM.TMVar [(Maybe UUID, Socket)] -> [(Maybe UUID, Socket)] -> IO () disconnectClients clientList = mapM_ - (\client@(_, clientSocket) -> do - sendMessage ServerQuit clientSocket - dropClient clientList client + (\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)] - -> (Maybe UUID, Socket) + -> UUID -> IO () -dropClient clientList (uuid, clientSocket) = do - STM.atomically $ do +dropClient clientList uuid = do + msock <- STM.atomically $ do clients <- STM.readTMVar clientList - let reducedClients = filter ((/= uuid) . fst) clients + 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 - close clientSocket + maybe + (pure ()) + close + msock -- | Process incoming connection requests processRequests :: Game () @@ -119,15 +131,23 @@ processRequests = do -- | Sends a specified message through given socket to the client sendMessage :: ServerMessage - -> Socket + -> UUID + -> STM.TMVar [(Maybe UUID, Socket)] -> IO () -sendMessage msg sock = do - let msgJson = A.encode msg +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 - VS.unsafeWith - msgVector - (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) + maybe + (dropClient clientList uuid) + (\sock -> + VS.unsafeWith + msgVector + (\ptr -> void $ sendBuf sock ptr (VS.length msgVector)) + ) + msock -- | receive incoming messages from clients receiveMessages @@ -137,8 +157,8 @@ receiveMessages receiveMessages clientsVar queue = do clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar mapM_ - (\(_, clientSocket) -> do - receiveMessage clientSocket queue + (\(muuid, clientSocket) -> do + receiveMessage clientSocket queue muuid clientsVar ) clients @@ -160,12 +180,24 @@ handleMessages = do receiveMessage :: Socket -> STM.TQueue ClientMessage + -> Maybe UUID + -> STM.TMVar [(Maybe UUID, Socket)] -> IO () -receiveMessage sock queue = do +receiveMessage sock queue muuid clientList = do let maxBufferLength = 4096 mmsg <- do ptr <- mallocArray maxBufferLength - bufferLength <- recvBuf sock ptr 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 @@ -208,7 +240,7 @@ handleMessage stateContainer readerContainer msg = do clients void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients putStrLn $ "Accepted Client with UUID " <> show clientId - sendMessage (AcceptClient clientId) clientSock + sendMessage (AcceptClient clientId) clientId clientList ClientMessage clientId payload -> case payload of ClientQuit -> do @@ -230,8 +262,7 @@ handleMessage stateContainer readerContainer msg = 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 + sendMessage (ProvideInitialWizard freshWizard) clientId clientList ClientReady -> do putStrLn $ "client " <> show clientId <> " is ready!" STM.atomically $ do @@ -278,7 +309,7 @@ sendPings = do when (isJust clientSock) $ if timeDiff > realToFrac maxTimeout then do - liftIO $ dropClient (scClientSockets stateContainer) (Just plId, fromJust clientSock) + liftIO $ dropClient (scClientSockets stateContainer) plId put stateContainer else do random <- liftIO nextRandom @@ -286,7 +317,8 @@ sendPings = do liftIO $ sendMessage ( Ping random ) - (fromJust clientSock) + plId + (scClientSockets stateContainer) let newPlayer = player { playerLastPong = newPong }