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

This commit is contained in:
Tissevert 2019-12-24 00:39:56 +01:00
parent 4a535caccc
commit dc920bd80b
2 changed files with 30 additions and 14 deletions

View file

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

View file

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