diff --git a/src/Automaton.hs b/src/Automaton.hs index 284071e..eaaa762 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -5,17 +5,13 @@ module Automaton ( import qualified App (Context(..), T, current, debug, get, server, try, update_) import Control.Monad.Reader (asks) -import Data.Map (Map, (!?)) import qualified Game (new, play) -import qualified Hanafuda.KoiKoi as KoiKoi ( - Game(..), GameID, Step(..) - ) import qualified Hanafuda.Message as Message (FromClient(..), T(..)) import qualified Messaging ( broadcast, get, notifyPlayers, relay, send, sendTo, update ) import qualified RW (RW(..)) -import qualified Server (endGame, get, logIn, logOut, update, room) +import qualified Server (logIn, logOut, update, room) import qualified Session (Status(..), T(..), Update) receive :: Session.Status -> Message.FromClient -> App.T () @@ -51,10 +47,9 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do newStatus <- if accept then do - gameID <- Game.new (for, to) - game <- Server.get gameID <$> App.server + game <- Game.new (for, to) Messaging.notifyPlayers game [] - return $ Session.Playing gameID + return Session.Playing else do Messaging.broadcast $ Messaging.update {Message.alone = [for, to]} return $ Session.LoggedIn True @@ -62,27 +57,14 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do setSessionStatus newStatus _ -> sendError "They're not waiting for your answer" -receive (Session.Playing gameID) (Message.Play {Message.move, Message.onGame}) = do +receive Session.Playing (Message.Play {Message.move, Message.onGame}) = do playerID <- asks App.playerID result <- Game.play playerID move onGame case result of Left message -> sendError message - Right (newGame, logs) -> do - case KoiKoi.step newGame of - KoiKoi.Over -> do - App.debug $ "Game " ++ show gameID ++ " ended" - App.update_ $ Server.endGame gameID - _ -> return () - Messaging.notifyPlayers newGame logs + Right (newGame, logs) -> Messaging.notifyPlayers newGame logs -receive (Session.Playing gameID) Message.Quit = do - games <- (RW.get <$> App.server :: App.T (Map KoiKoi.GameID KoiKoi.Game)) - case games !? gameID of - Nothing -> do - playerID <- asks App.playerID - Messaging.broadcast $ Messaging.update {Message.alone = [playerID]} - setSessionStatus (Session.LoggedIn True) - _ -> sendError "Game is still running" +receive Session.Playing Message.Quit = setSessionStatus (Session.LoggedIn True) receive state _ = sendError $ "Invalid message in state " ++ show state diff --git a/src/Game.hs b/src/Game.hs index 2b99ecf..4390a0b 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -5,7 +5,7 @@ module Game ( , play ) where -import qualified App (T, server, update) +import qualified App (T, server) import Control.Monad.Except (runExceptT) import Control.Monad.Reader (lift) import Control.Monad.Writer (runWriterT) @@ -17,7 +17,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Map ((!), Map, mapWithKey) import qualified Hanafuda (Pack) -import Hanafuda.KoiKoi (Game, GameID, Mode(..), Player, PlayerID, Players) +import Hanafuda.KoiKoi (Game, Mode(..), Player, PlayerID, Players) import qualified Hanafuda.KoiKoi as KoiKoi ( Action, Game(..), Move(..), play, new ) @@ -25,11 +25,10 @@ import Hanafuda.Message (PrivateState(..), PublicGame(..), PublicPlayer(..), Pub import qualified Hanafuda.Player as Player (Player(..), Players(..), get) import Keys (T(..)) import qualified Keys (public, secret) -import qualified Server (T(..), register) +import qualified Server (T(..)) -new :: (PlayerID, PlayerID) -> App.T GameID -new (for, to) = - Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update +new :: (PlayerID, PlayerID) -> App.T Game +new (for, to) = lift $ KoiKoi.new (for, to) WholeYear exportPlayers :: Game -> Map PlayerID Player exportPlayers game = diff --git a/src/Server.hs b/src/Server.hs index e185c8b..9270e09 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -6,7 +6,6 @@ module Server ( T(..) , disconnect - , endGame , get , logIn , logOut @@ -21,7 +20,7 @@ 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.KoiKoi (Game, GameID, PlayerID) +import Hanafuda.KoiKoi (PlayerID) import Hanafuda.Message (PlayerStatus(..), Room) import Keys (getKeys) import qualified Keys (T) @@ -31,12 +30,10 @@ import qualified Session (Status(..), T(..), Update) type Names = Set Text type Players = Map PlayerID Text type Sessions = Map PlayerID Session.T -type Games = Map GameID Game data T = T { names :: Names , players :: Players , sessions :: Sessions - , games :: Games , keys :: Keys.T } @@ -52,10 +49,6 @@ instance RW.RW Sessions T where get = sessions set sessions server = server {sessions} -instance RW.RW Games T where - get = games - set games server = server {games} - export :: Sessions -> PlayerID -> Text -> PlayerStatus export sessions playerID playerName = PlayerStatus (playerName, alone) where @@ -72,7 +65,6 @@ new = getKeys >>= \keys -> return $ T { names = Set.empty , players = Map.empty , sessions = Map.empty - , games = Map.empty , keys } @@ -92,10 +84,6 @@ disconnect :: PlayerID -> T -> T disconnect playerID = RW.update (delete playerID :: Sessions -> Sessions) . logOut playerID -endGame :: GameID -> T -> T -endGame playerID = - RW.update (delete playerID :: Games -> Games) - logIn :: Text -> PlayerID -> T -> Either String T logIn name playerID server = RW.update (Set.insert name) . diff --git a/src/Session.hs b/src/Session.hs index 621c540..5982ab4 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -7,7 +7,7 @@ module Session ( , open ) where -import Hanafuda.KoiKoi (GameID, PlayerID) +import Hanafuda.KoiKoi (PlayerID) import Network.WebSockets (Connection) import qualified RW (RW(..)) @@ -15,7 +15,7 @@ data Status = LoggedIn Bool | Answering PlayerID | Waiting PlayerID - | Playing GameID + | Playing deriving (Show) data T = T {