Handle Player log out with multiple sessions and get rid of the too simple «logOut» function
This commit is contained in:
parent
4a535caccc
commit
dc920bd80b
2 changed files with 30 additions and 14 deletions
14
src/Main.hs
14
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
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in a new issue