Stop imposing only one game per user, it was silly and finally harder to do well than to simply keep games by ID and allow several games in parallel for one user

src/Automaton.hs

@@ -10,13 +10,13 @@ import Data.Aeson (encode, eitherDecode')
 import Data.ByteString.Lazy.Char8 (ByteString, append, pack, putStrLn)
 import qualified Data.ByteString.Lazy.Char8 as ByteString (concat)
 import Data.Map ((!))
-import qualified Data.Map as Map (delete, empty, member)
+import qualified Data.Map as Map (delete, empty, lookup)
 import Control.Monad.Reader (ReaderT, ask)
 import Control.Monad.Trans (lift)
 import Hanafuda.KoiKoi (Step(..))
-import Hanafuda.Message (Coordinates(..), FromClient(..), T(..), orderCoordinates)
+import Hanafuda.Message (FromClient(..), T(..), orderCoordinates)
 import qualified Hanafuda.Message as Message (
-    T(..), FromClient, PublicGame(..), PublicState(..)
+    Coordinates(..), FromClient, PublicGame(..), PublicState(..), T(..)
   )
 import Network.WebSockets (Connection, receiveData, sendTextData)
 import Prelude hiding (error, putStrLn)
@@ -58,16 +58,14 @@ answer (Message.Relay {Message.from, Message.message = Message.LogIn {Message.na
   | from == key = return $ LoggedIn {key, name}
 -}
 
-answer state@(Connected {games}) (Relay {from, message = Invitation {}}) =
-  -- policy : one game per player only
-  send (Answer {accept = not $ Map.member from games, to = from})
-  >> return state
+answer state@(Connected {}) (Relay {from, message = Invitation {}}) =
+  send (Answer {accept = True, to = from}) >> return state
 
 answer state@(Connected {playerID, games}) message@(Game {}) = do
   case Message.step $ Message.public game of
     Over ->
-      let opponentID = Message.nextPlayer (Message.public game) ! playerID in
-      return $ state {games = Map.delete opponentID games}
+      let xGameID = Message.gameID . Message.coordinates $ Message.public game in
+      return $ state {games = Map.delete xGameID games}
     _ ->
       if Message.playing (Message.public game) == playerID
       then
@@ -82,21 +80,21 @@ answer state (Error {error}) = do
   debug $ "Received error from server : " `append` pack error
   return state
 
-answer state@(Connected {games}) (Relay {from, message = Sync {latestKnown}})
-  | not $ Map.member from games =
-      send (Yield {onGameID = gameID latestKnown, to = from}) >> return state
-  | otherwise =
-    case orderCoordinates latestKnownHere latestKnown of
-      Just LT -> send $ Yield {onGameID = gameID latestKnown, to = from}
-      Just GT -> send $ Share {gameSave = game}
+answer state@(Connected {games}) (Relay {from, message = Sync {latestKnown}}) =
+  case Map.lookup gameID games of
+    Nothing -> send $ Yield {onGameID = gameID, to = from}
+    Just game ->
+      let latestKnownHere = Message.coordinates $ Message.public game in
+      case orderCoordinates latestKnown latestKnownHere of
+        Just LT -> send $ Share {gameSave = game}
+        Just GT -> send $ Yield {onGameID = gameID, to = from}
         _ -> return ()
   >> return state
   where
-      game = games ! from
-      latestKnownHere = Message.coordinates $ Message.public game
+    gameID = Message.gameID latestKnown
 
-answer state@(Connected {games}) (Relay {from, message = Yield {}}) =
-  send (Share {gameSave = games ! from}) >> return state
+answer state@(Connected {games}) (Relay {message = Yield {onGameID}}) =
+  send (Share {gameSave = games ! onGameID}) >> return state
 
 {-
  - Ignore

src/Session.hs

@@ -8,7 +8,7 @@ module Session (
 import Config (libDir)
 import Data.Map (Map)
 import qualified Data.Map as Map (empty)
-import Hanafuda.KoiKoi (PlayerID)
+import Hanafuda.KoiKoi (GameID, PlayerID)
 import qualified Hanafuda.Message as Message (PublicGame)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath ((</>))
@@ -17,7 +17,7 @@ data State =
     New
   | Connected {
         playerID :: PlayerID
-      , games :: Map PlayerID Message.PublicGame
+      , games :: Map GameID Message.PublicGame
     }
   deriving Show