Handle Player log out with multiple sessions and get rid of the too simple «logOut» function

src/Main.hs

@@ -2,27 +2,29 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main where
 
-import qualified App (Context(..), T, update)
+import qualified App (Context(..), T, exec)
 import qualified Automaton (loop)
 import qualified Config (listenPort)
 import Control.Concurrent (newMVar, modifyMVar)
 import Control.Exception (finally)
 import Control.Monad.Reader (ReaderT(..), asks)
 import Crypto.Saltine (sodiumInit)
-import qualified Hanafuda.Message as Message (FromClient(..))
+import qualified Hanafuda.Message as Message (T(..))
-import Messaging (broadcast, relay)
+import Messaging (broadcast)
 import Network.HTTP.Types.Status (badRequest400)
 import Network.Wai (responseLBS)
 import Network.Wai.Handler.Warp (run)
 import Network.Wai.Handler.WebSockets (websocketsOr)
 import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
-import qualified Server (logOut, new, register)
+import qualified Server (close, new, register)
 import qualified Session (open)
 
 exit :: App.T ()
 exit = do
-  asks App.sessionID >>= App.update . Server.logOut
+  mPlayerID <- asks App.sessionID >>= App.exec . Server.close
-  Messaging.relay Message.LogOut broadcast
+  case mPlayerID of
+    Nothing -> return ()
+    Just playerID -> Messaging.broadcast $ Message.LogOut playerID
 
 serverApp :: App.T () -> App.T () -> IO ServerApp
 serverApp onEnter onExit = do

src/Server.hs

@@ -5,9 +5,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Server (
       T(..)
+    , close
     , get
     , logIn
-    , logOut
     , new
     , register
     , room
@@ -94,10 +94,24 @@ logIn name playerID sessionID =
   RW.update (push playerID sessionID) .
   update sessionID (Session.setPlayer playerID name)
 
-logOut :: Session.ID -> T -> T
+close :: Monad m => Session.ID -> T -> m (T, Maybe PlayerID)
-logOut sessionID server =
+close sessionID server =
-  RW.update (delete sessionID :: Sessions -> Sessions) $
+  return . performUpdates $ popSession sessionID server
-  case (sessions server !? sessionID) >>= Session.player of
+  where
-    Nothing -> server
+    performUpdates (updateSessionIDs, mPlayerID) = (
-    Just player ->
+            RW.update (delete sessionID :: Sessions -> Sessions)
-      RW.update (delete (Player.playerID player) :: SessionIDs -> SessionIDs) server
+          . RW.update (updateSessionIDs :: SessionIDs -> SessionIDs) $ server
+        , mPlayerID
+      )
+
+popSession :: Session.ID -> T -> (SessionIDs -> SessionIDs, Maybe PlayerID)
+popSession sessionID (T {sessions, sessionIDsByPlayerID}) =
+  case findPlayerID of
+    Nothing -> (id, Nothing)
+    Just (playerID, [_]) -> (delete playerID, Just playerID)
+    Just (playerID, _) -> (purgeSession playerID, Nothing)
+  where
+    findPlayerID = do
+      playerID <- fmap Player.playerID . Session.player =<< (sessions !? sessionID)
+      (,) playerID <$> (sessionIDsByPlayerID !? playerID)
+    purgeSession = adjust (filter (/= sessionID))