hanafuda/server
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Main.hs
View File

@ -2,27 +2,29 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module Main where module Main where
import qualified App (Context(..), T, update) import qualified App (Context(..), T, exec)
import qualified Automaton (loop) import qualified Automaton (loop)
import qualified Config (listenPort) import qualified Config (listenPort)
import Control.Concurrent (newMVar, modifyMVar) import Control.Concurrent (newMVar, modifyMVar)
import Control.Exception (finally) import Control.Exception (finally)
import Control.Monad.Reader (ReaderT(..), asks) import Control.Monad.Reader (ReaderT(..), asks)
import Crypto.Saltine (sodiumInit) 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.HTTP.Types.Status (badRequest400)
import Network.Wai (responseLBS) import Network.Wai (responseLBS)
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
import Network.Wai.Handler.WebSockets (websocketsOr) import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions) import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
import qualified Server (logOut, new, register) import qualified Server (close, new, register)
import qualified Session (open) import qualified Session (open)
exit :: App.T () exit :: App.T ()
exit = do 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 :: App.T () -> App.T () -> IO ServerApp
serverApp onEnter onExit = do serverApp onEnter onExit = do

30
src/Server.hs
View File

@ -5,9 +5,9 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Server ( module Server (
T(..) T(..)
, close
, get , get
, logIn , logIn
, logOut
, new , new
, register , register
, room , room
@ -94,10 +94,24 @@ logIn name playerID sessionID =
RW.update (push playerID sessionID) . RW.update (push playerID sessionID) .
update sessionID (Session.setPlayer playerID name) 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))