diff --git a/src/Automaton.hs b/src/Automaton.hs index eaaa762..414ebb4 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -8,37 +8,36 @@ import Control.Monad.Reader (asks) import qualified Game (new, play) import qualified Hanafuda.Message as Message (FromClient(..), T(..)) import qualified Messaging ( - broadcast, get, notifyPlayers, relay, send, sendTo, update + broadcast, get, notifyPlayers, relay, send, sendTo ) import qualified RW (RW(..)) import qualified Server (logIn, logOut, update, room) import qualified Session (Status(..), T(..), Update) -receive :: Session.Status -> Message.FromClient -> App.T () +receive :: Message.FromClient -> Bool -> App.T () -receive (Session.LoggedIn False) logIn@(Message.LogIn login) = +receive logIn@(Message.LogIn login) False = asks App.playerID >>= App.try . (Server.logIn login) >>= maybe (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True)) sendError -receive (Session.LoggedIn True) logOut@Message.LogOut = do +receive logOut@Message.LogOut True = do Messaging.relay logOut Messaging.broadcast asks App.playerID >>= App.update_ . Server.logOut - setSessionStatus (Session.LoggedIn False) + setSessionStatus (Session.Status False) -receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = 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.broadcast $ Messaging.update {Message.paired = [from, to]} (Messaging.relay invitation $ Messaging.sendTo [to]) setSessionStatus (Session.Waiting to) _ -> sendError "They just left" -receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do +receive (Session.LoggedIn True) message@(Message.Answer {Message.accept}) = do session <- App.get to playerID <- asks App.playerID case Session.status session of @@ -51,7 +50,6 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do Messaging.notifyPlayers game [] return Session.Playing else do - Messaging.broadcast $ Messaging.update {Message.alone = [for, to]} return $ Session.LoggedIn True App.update_ $ Server.update to (RW.set newStatus :: Session.Update) setSessionStatus newStatus @@ -80,8 +78,7 @@ setSessionStatus newStatus = do loop :: App.T () loop = do message <- Messaging.get - status <- Session.status <$> App.current - status `receive` message + receive message (Status.loggedIn . Session.status <$> App.current) loop start :: App.T () diff --git a/src/Messaging.hs b/src/Messaging.hs index 0d77871..0b7e8d2 100644 --- a/src/Messaging.hs +++ b/src/Messaging.hs @@ -10,7 +10,6 @@ module Messaging ( , relay , send , sendTo - , update ) where import qualified App (Context(..), T, connection, debug, server) @@ -67,9 +66,6 @@ get = pong Ping = send Pong >> get pong m = return m -update :: T -update = Update {alone = [], paired = []} - notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T () notifyPlayers game logs = forM_ (keys $ KoiKoi.scores game) $ \k -> do diff --git a/src/Session.hs b/src/Session.hs index 5982ab4..1097696 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -7,16 +7,12 @@ module Session ( , open ) where -import Hanafuda.KoiKoi (PlayerID) import Network.WebSockets (Connection) import qualified RW (RW(..)) -data Status = - LoggedIn Bool - | Answering PlayerID - | Waiting PlayerID - | Playing - deriving (Show) +newtype Status = Status { + loggedIn :: Bool + } deriving (Show) data T = T { connection :: Connection @@ -31,5 +27,5 @@ instance RW.RW Status T where open :: Connection -> T open connection = T { connection - , status = LoggedIn False + , status = Status False }