From dc920bd80b32e170b034148a358cb964c0abdeb0 Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Tue, 24 Dec 2019 00:39:56 +0100
Subject: [PATCH] =?UTF-8?q?Handle=20Player=20log=20out=20with=20multiple?=
 =?UTF-8?q?=20sessions=20and=20get=20rid=20of=20the=20too=20simple=20?=
 =?UTF-8?q?=C2=ABlogOut=C2=BB=20function?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Main.hs   | 14 ++++++++------
 src/Server.hs | 30 ++++++++++++++++++++++--------
 2 files changed, 30 insertions(+), 14 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index c620c75..a2cdebe 100644
--- a/src/Main.hs
+++ b/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 Messaging (broadcast, relay)
+import qualified Hanafuda.Message as Message (T(..))
+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
-  Messaging.relay Message.LogOut broadcast
+  mPlayerID <- asks App.sessionID >>= App.exec . Server.close
+  case mPlayerID of
+    Nothing -> return ()
+    Just playerID -> Messaging.broadcast $ Message.LogOut playerID
 
 serverApp :: App.T () -> App.T () -> IO ServerApp
 serverApp onEnter onExit = do
diff --git a/src/Server.hs b/src/Server.hs
index a685d07..e10c281 100644
--- a/src/Server.hs
+++ b/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
-logOut sessionID server =
-  RW.update (delete sessionID :: Sessions -> Sessions) $
-  case (sessions server !? sessionID) >>= Session.player of
-    Nothing -> server
-    Just player ->
-      RW.update (delete (Player.playerID player) :: SessionIDs -> SessionIDs) server
+close :: Monad m => Session.ID -> T -> m (T, Maybe PlayerID)
+close sessionID server =
+  return . performUpdates $ popSession sessionID server
+  where
+    performUpdates (updateSessionIDs, mPlayerID) = (
+            RW.update (delete sessionID :: Sessions -> Sessions)
+          . 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))