introduce proper exception handling

This commit is contained in:
nek0 2024-03-29 10:34:15 +01:00
parent 95193f5fd1
commit be888101a0
2 changed files with 60 additions and 25 deletions

View file

@ -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)

View file

@ -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
}