From 3aca8283e2a95269d6b01b7a1e66b8eafc3bdb30 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Mon, 28 Oct 2019 08:19:14 +0100 Subject: [PATCH] WIP: Still breaking everything, trying to replace PlayerID by SessionID now --- src/Automaton.hs | 18 ++++++++---------- src/Server.hs | 38 +++++++++++++------------------------- src/Session.hs | 5 ++++- 3 files changed, 25 insertions(+), 36 deletions(-) diff --git a/src/Automaton.hs b/src/Automaton.hs index 414ebb4..a504ce7 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -11,7 +11,7 @@ import qualified Messaging ( broadcast, get, notifyPlayers, relay, send, sendTo ) import qualified RW (RW(..)) -import qualified Server (logIn, logOut, update, room) +import qualified Server (logIn, logOut, update, players) import qualified Session (Status(..), T(..), Update) receive :: Message.FromClient -> Bool -> App.T () @@ -19,7 +19,7 @@ receive :: Message.FromClient -> Bool -> App.T () receive logIn@(Message.LogIn login) False = asks App.playerID >>= App.try . (Server.logIn login) >>= maybe - (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True)) + (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.Status True)) sendError receive logOut@Message.LogOut True = do @@ -29,13 +29,11 @@ receive logOut@Message.LogOut True = do receive invitation@(Message.Invitation {Message.to}) True = do session <- App.get to - case Session.status session of - Session.LoggedIn True -> do - from <- asks App.playerID - App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update)) - (Messaging.relay invitation $ Messaging.sendTo [to]) - setSessionStatus (Session.Waiting to) - _ -> sendError "They just left" + if Session.loggedIn $ Session.status session + then do + from <- asks App.playerID + App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update)) + else sendError "They just left" receive (Session.LoggedIn True) message@(Message.Answer {Message.accept}) = do session <- App.get to @@ -84,5 +82,5 @@ loop = do start :: App.T () start = do App.debug "Initial state" - Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send + Message.Welcome . Server.players <$> App.server <*> asks App.playerID >>= Messaging.send loop diff --git a/src/Server.hs b/src/Server.hs index 9270e09..1caab15 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -11,28 +11,27 @@ module Server ( , logOut , new , register - , room , update ) where -import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey) +import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax) import qualified Data.Map as Map (empty) import Data.Set (Set, member) import qualified Data.Set as Set (delete, empty, insert) import Data.Text (Text) +import Hanafuda.ID (ID) import Hanafuda.KoiKoi (PlayerID) -import Hanafuda.Message (PlayerStatus(..), Room) +import Hanafuda.Message (Room) import Keys (getKeys) import qualified Keys (T) import qualified RW (RW(..)) -import qualified Session (Status(..), T(..), Update) +import qualified Session (ID, Status(..), T(..), Update) type Names = Set Text -type Players = Map PlayerID Text -type Sessions = Map PlayerID Session.T +type Sessions = Map Session.ID Session.T data T = T { names :: Names - , players :: Players + , players :: Room , sessions :: Sessions , keys :: Keys.T } @@ -41,7 +40,7 @@ instance RW.RW Names T where get = names set names server = server {names} -instance RW.RW Players T where +instance RW.RW Room T where get = players set players server = server {players} @@ -49,17 +48,6 @@ instance RW.RW Sessions T where get = sessions set sessions server = server {sessions} -export :: Sessions -> PlayerID -> Text -> PlayerStatus -export sessions playerID playerName = PlayerStatus (playerName, alone) - where - alone = - case Session.status (sessions ! playerID) of - Session.LoggedIn True -> True - _ -> False - -room :: T -> Room -room (T {players, sessions}) = mapWithKey (export sessions) players - new :: IO T new = getKeys >>= \keys -> return $ T { names = Set.empty @@ -80,15 +68,15 @@ update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T update playerID updator = RW.update (adjust updator playerID :: Map a b -> Map a b) -disconnect :: PlayerID -> T -> T -disconnect playerID = - RW.update (delete playerID :: Sessions -> Sessions) . logOut playerID +disconnect :: Session.ID -> T -> T +disconnect sessionID = + RW.update (delete sessionID :: Sessions -> Sessions) . logOut sessionID logIn :: Text -> PlayerID -> T -> Either String T logIn name playerID server = RW.update (Set.insert name) . RW.update (insert playerID name) . - update playerID (RW.set $ Session.LoggedIn True :: Session.Update) <$> + update playerID (RW.set $ Session.Status True :: Session.Update) <$> if name `member` names server then Left "This name is already registered" else Right server @@ -98,7 +86,7 @@ logOut playerID server = maybe server (\playerName -> - RW.update (delete playerID :: Players -> Players) $ - update playerID (RW.set $ Session.LoggedIn False :: Session.Update) $ + RW.update (delete playerID :: Room -> Room) $ + update playerID (RW.set $ Session.Status False :: Session.Update) $ RW.update (Set.delete playerName :: Names -> Names) server) (players server !? playerID) diff --git a/src/Session.hs b/src/Session.hs index 1097696..763d370 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -1,12 +1,14 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} module Session ( - Status(..) + ID + , Status(..) , T(..) , Update , open ) where +import qualified Hanafuda.ID as Hanafuda (ID) import Network.WebSockets (Connection) import qualified RW (RW(..)) @@ -18,6 +20,7 @@ data T = T { connection :: Connection , status :: Status } +type ID = Hanafuda.ID T type Update = T -> T instance RW.RW Status T where