introduce proper exception handling

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)

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
                   }