fix ws memory issues

Author: jruehlow

service/src/Foundation.hs

@@ -43,18 +43,18 @@ data App = App
 type ServerMessage = LBS.ByteString
 
 data LobbyState = LobbyState
-  { lobbyClients :: Map UserId (TBQueue ServerMessage),
-    lobbyRaceState :: Maybe RaceState
+  { lobbyClients :: !(Map UserId (TBQueue ServerMessage)),
+    lobbyRaceState :: !(Maybe RaceState)
   }
 
 data RaceState = RaceState
-  { raceEra :: Text,
-    raceWordCount :: Int,
-    raceStartTime :: Maybe UTCTime,
-    raceProgress :: Map UserId Int, -- character index
-    raceWPM :: Map UserId Double, -- current WPM
-    raceCompleted :: Map UserId (Double, Double), -- final (wpm, accuracy)
-    raceTextLength :: Int
+  { raceEra :: !Text,
+    raceWordCount :: !Int,
+    raceStartTime :: !(Maybe UTCTime),
+    raceProgress :: !(Map UserId Int), -- character index
+    raceWPM :: !(Map UserId Double), -- current WPM
+    raceCompleted :: !(Map UserId (Double, Double)), -- final (wpm, accuracy)
+    raceTextLength :: !Int
   }
 
 -- This function also generates the following type synonyms:

service/src/Handler/MultiplayerWs.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -81,6 +82,10 @@ getMultiplayerWsR lobbyId = do
           atomically $
             modifyTVar' lobbiesTVar (Map.alter (removeClient userId) lobbyId)
         cleanup = do
+          liftIO . atomically $
+            writeTBQueue chan $
+              encode $
+                object ["type" .= ("close" :: Text)]
           liftIO removeClientIO
           liftIO $ broadcastState pool lobbiesTVar lobbyId
 
@@ -103,21 +108,34 @@ sendLoop chan = forever $ do
   msg <- liftIO $ atomically $ readTBQueue chan
   sendTextData msg
 
-receiveLoop :: ConnectionPool -> TVar (Map Text LobbyState) -> Text -> UserId -> WebSocketsT Handler ()
-receiveLoop pool lobbiesTVar lobbyUId userId = forever $ do
-  msgE <- receiveDataMessageE
-  case msgE of
-    Left se ->
-      liftIO $ throwIO se
-    Right (WS.Text bs _mText) -> do
-      let txt = decodeUtf8 (LBS.toStrict bs)
-      case parseMessage txt of
-        Just cm ->
-          liftIO $
-            handleClientMessage pool lobbiesTVar lobbyUId userId cm
-        Nothing -> pure () -- Ignore invalid messages
-    Right (WS.Binary _bs) -> do
-      pure ()
+receiveLoop ::
+  ConnectionPool ->
+  TVar (Map Text LobbyState) ->
+  Text ->
+  UserId ->
+  WebSocketsT Handler ()
+-- Normal-closure frames are swallowed so they don’t reach Warp’s logger.
+receiveLoop pool lobbiesTVar lobbyUId userId = loop
+  where
+    loop = do
+      msgE <- receiveDataMessageE
+      case msgE of
+        Left se ->
+          case (fromException se :: Maybe WS.ConnectionException) of
+            Just (WS.CloseRequest 1000 _) -> pure ()
+            Just (WS.CloseRequest 1001 _) -> pure ()
+            Just WS.ConnectionClosed -> pure ()
+            _ -> liftIO $ throwIO se
+        Right (WS.Text bs _mText) -> do
+          let txt = decodeUtf8 (LBS.toStrict bs)
+          case parseMessage txt of
+            Just cm ->
+              liftIO $
+                handleClientMessage pool lobbiesTVar lobbyUId userId cm
+            Nothing -> pure () -- Ignore invalid messages
+          loop
+        Right (WS.Binary _bs) ->
+          loop
 
 -- Parse incoming WebSocket messages
 parseMessage :: Text -> Maybe ClientMessage
@@ -168,13 +186,13 @@ startRace era wordCount startTime ls =
         }
 
 updateProgress :: UserId -> Int -> Double -> LobbyState -> LobbyState
-updateProgress userId charIndex wpm ls@LobbyState {lobbyRaceState = Just rs} =
+updateProgress uid !charIdx !wpm ls@LobbyState {lobbyRaceState = Just rs} =
   ls
     { lobbyRaceState =
         Just
           rs
-            { raceProgress = Map.insert userId charIndex (raceProgress rs),
-              raceWPM = Map.insert userId wpm (raceWPM rs)
+            { raceProgress = Map.insert uid charIdx (raceProgress rs),
+              raceWPM = Map.insert uid wpm (raceWPM rs)
             }
     }
 updateProgress _ _ _ ls = ls