Remove all game storing from the server : a lot of remaining protocol operations are now meaningless and will require a huge redesign

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
 

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 =

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) .

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 {