Implement multi-sessions for players

src/Automaton.hs

@@ -18,7 +18,7 @@ receive :: Message.FromClient -> Session.Status -> App.T ()
 
 receive (Message.Hello {Message.name}) Nothing = do
   sessionID <- asks App.sessionID
-  playerID <- App.exec (Server.register sessionID)
+  playerID <- App.exec (Server.register [sessionID])
   room <- App.get Server.room
   Messaging.send $ Message.Welcome room playerID
   App.update (Server.update sessionID $ Session.setPlayer playerID name)

src/Messaging.hs

@@ -41,7 +41,7 @@ sendToSessions sessions obj = do
 sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T ()
 sendTo playerIDs obj = do
   sessions <- App.get $ Server.sessionsWhere selectedPlayer
-  sendToSessions (elems sessions) obj
+  sendToSessions (foldl (++) [] sessions) obj
   where
     selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs
 

src/Server.hs

@@ -16,8 +16,8 @@ module Server (
     , update
   ) where
 
-import Data.Map (Map, (!), (!?), adjust, delete, insert)
-import qualified Data.Map as Map (empty, lookup, mapMaybeWithKey)
+import Data.Map (Map, (!), (!?), adjust, delete, insert, mapMaybe)
+import qualified Data.Map as Map (empty, foldlWithKey, lookup)
 import Data.Text (Text)
 import Hanafuda.KoiKoi (PlayerID)
 import Hanafuda.Message (Room)
@@ -28,7 +28,7 @@ import qualified RW (RW(..))
 import qualified Session (ID, T(..), setPlayer)
 import System.Random (Random(..))
 
-type SessionIDs = Map PlayerID Session.ID
+type SessionIDs = Map PlayerID [Session.ID]
 type Sessions = Map Session.ID Session.T
 data T = T {
       keys :: Keys.T
@@ -52,15 +52,27 @@ new = getKeys >>= \keys -> return $ T {
   }
 
 room :: T -> Room
-room = fmap Player.name . select (\_ -> Session.player)
+room = mapMaybe keepName . select (\_ -> Session.player)
+  where
+    keepName [] = Nothing
+    keepName (player:_) = Just $ Player.name player
 
-select :: (PlayerID -> Session.T -> Maybe a) -> T -> Map PlayerID a
+push :: Ord k => k -> v -> Map k [v] -> Map k [v]
+push key value m =
+  (maybe (insert key [value]) (insert key . (value:)) $ Map.lookup key m) m
+
+select :: (PlayerID -> Session.T -> Maybe a) -> T -> Map PlayerID [a]
 select selector (T {sessionIDsByPlayerID, sessions}) =
-  Map.mapMaybeWithKey selected sessionIDsByPlayerID where
-  selected playerID sessionID =
-    Map.lookup sessionID sessions >>= selector playerID
+  Map.foldlWithKey (\accumulator playerID sessionIDs ->
+      foldl (\acc ->
+          maybe acc (\v -> push playerID v acc) . selected playerID
+        ) accumulator sessionIDs
+    ) Map.empty sessionIDsByPlayerID
+  where
+    selected playerID sessionID =
+      Map.lookup sessionID sessions >>= selector playerID
 
-sessionsWhere :: (PlayerID -> Session.T -> Bool) -> T -> Map PlayerID Session.T
+sessionsWhere :: (PlayerID -> Session.T -> Bool) -> T -> Map PlayerID [Session.T]
 sessionsWhere predicate = select selectorOfPredicate where
   selectorOfPredicate playerID session =
     if predicate playerID session then Just session else Nothing
@@ -79,7 +91,7 @@ update keyID updator =
 
 logIn :: Text -> PlayerID -> Session.ID -> T -> T
 logIn name playerID sessionID =
-  RW.update (insert playerID sessionID) .
+  RW.update (push playerID sessionID) .
   update sessionID (Session.setPlayer playerID name)
 
 logOut :: Session.ID -> T -> T