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 {}}) =
+answer state@(Connected {}) (Relay {from, message = Invitation {}}) =
-  -- policy : one game per player only
+  send (Answer {accept = True, to = from}) >> return state
-  send (Answer {accept = not $ Map.member from games, 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
+      let xGameID = Message.gameID . Message.coordinates $ Message.public game in
-      return $ state {games = Map.delete opponentID games}
+      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}})
+answer state@(Connected {games}) (Relay {from, message = Sync {latestKnown}}) =
-  | not $ Map.member from games =
+  case Map.lookup gameID games of
-      send (Yield {onGameID = gameID latestKnown, to = from}) >> return state
+    Nothing -> send $ Yield {onGameID = gameID, to = from}
-  | otherwise =
+    Just game ->
-    case orderCoordinates latestKnownHere latestKnown of
+      let latestKnownHere = Message.coordinates $ Message.public game in
-      Just LT -> send $ Yield {onGameID = gameID latestKnown, to = from}
+      case orderCoordinates latestKnown latestKnownHere of
-      Just GT -> send $ Share {gameSave = game}
+        Just LT -> send $ Share {gameSave = game}
+        Just GT -> send $ Yield {onGameID = gameID, to = from}
         _ -> return ()
   >> return state
   where
-      game = games ! from
+    gameID = Message.gameID latestKnown
-      latestKnownHere = Message.coordinates $ Message.public game
 
-answer state@(Connected {games}) (Relay {from, message = Yield {}}) =
+answer state@(Connected {games}) (Relay {message = Yield {onGameID}}) =
-  send (Share {gameSave = games ! from}) >> return state
+  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