WIP: Still breaking everything, trying to replace PlayerID by SessionID now

src/Automaton.hs

@@ -11,7 +11,7 @@ import qualified Messaging (
     broadcast, get, notifyPlayers, relay, send, sendTo
   )
 import qualified RW (RW(..))
-import qualified Server (logIn, logOut, update, room)
+import qualified Server (logIn, logOut, update, players)
 import qualified Session (Status(..), T(..), Update)
 
 receive :: Message.FromClient -> Bool -> App.T ()
@@ -19,7 +19,7 @@ receive :: Message.FromClient -> Bool -> App.T ()
 receive logIn@(Message.LogIn login) False =
   asks App.playerID >>= App.try . (Server.logIn login)
   >>= maybe
-   (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True))
+   (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.Status True))
    sendError
 
 receive logOut@Message.LogOut True = do
@@ -29,13 +29,11 @@ receive logOut@Message.LogOut True = do
 
 receive invitation@(Message.Invitation {Message.to}) True = do
   session <- App.get to
-  case Session.status session of
-    Session.LoggedIn True -> do
-      from <- asks App.playerID
-      App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update))
-      (Messaging.relay invitation $ Messaging.sendTo [to])
-      setSessionStatus (Session.Waiting to)
-    _ -> sendError "They just left"
+  if Session.loggedIn $ Session.status session
+  then do
+    from <- asks App.playerID
+    App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update))
+  else sendError "They just left"
 
 receive (Session.LoggedIn True) message@(Message.Answer {Message.accept}) = do
   session <- App.get to
@@ -84,5 +82,5 @@ loop = do
 start :: App.T ()
 start = do
   App.debug "Initial state"
-  Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send
+  Message.Welcome . Server.players <$> App.server <*> asks App.playerID >>= Messaging.send
   loop

src/Server.hs

@@ -11,28 +11,27 @@ module Server (
     , logOut
     , new
     , register
-    , room
     , update
   ) where
 
-import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
+import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax)
 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.ID (ID)
 import Hanafuda.KoiKoi (PlayerID)
-import Hanafuda.Message (PlayerStatus(..), Room)
+import Hanafuda.Message (Room)
 import Keys (getKeys)
 import qualified Keys (T)
 import qualified RW (RW(..))
-import qualified Session (Status(..), T(..), Update)
+import qualified Session (ID, Status(..), T(..), Update)
 
 type Names = Set Text
-type Players = Map PlayerID Text
-type Sessions = Map PlayerID Session.T
+type Sessions = Map Session.ID Session.T
 data T = T {
       names :: Names
-    , players :: Players
+    , players :: Room
     , sessions :: Sessions
     , keys :: Keys.T
   }
@@ -41,7 +40,7 @@ instance RW.RW Names T where
   get = names
   set names server = server {names}
 
-instance RW.RW Players T where
+instance RW.RW Room T where
   get = players
   set players server = server {players}
 
@@ -49,17 +48,6 @@ instance RW.RW Sessions T where
   get = sessions
   set sessions server = server {sessions}
 
-export :: Sessions -> PlayerID -> Text -> PlayerStatus
-export sessions playerID playerName = PlayerStatus (playerName, alone)
-  where
-    alone =
-      case Session.status (sessions ! playerID) of
-        Session.LoggedIn True -> True
-        _ -> False
-
-room :: T -> Room
-room (T {players, sessions}) = mapWithKey (export sessions) players
-
 new :: IO T
 new = getKeys >>= \keys -> return $ T {
       names = Set.empty
@@ -80,15 +68,15 @@ update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T
 update playerID updator =
   RW.update (adjust updator playerID :: Map a b -> Map a b)
 
-disconnect :: PlayerID -> T -> T
-disconnect playerID =
-  RW.update (delete playerID :: Sessions -> Sessions) . logOut playerID
+disconnect :: Session.ID -> T -> T
+disconnect sessionID =
+  RW.update (delete sessionID :: Sessions -> Sessions) . logOut sessionID
 
 logIn :: Text -> PlayerID -> T -> Either String T
 logIn name playerID server =
   RW.update (Set.insert name) .
   RW.update (insert playerID name) .
-  update playerID (RW.set $ Session.LoggedIn True :: Session.Update) <$>
+  update playerID (RW.set $ Session.Status True :: Session.Update) <$>
   if name `member` names server
     then Left "This name is already registered"
     else Right server
@@ -98,7 +86,7 @@ logOut playerID server =
   maybe
     server
     (\playerName ->
-      RW.update (delete playerID :: Players -> Players) $
-      update playerID (RW.set $ Session.LoggedIn False :: Session.Update) $
+      RW.update (delete playerID :: Room -> Room) $
+      update playerID (RW.set $ Session.Status False :: Session.Update) $
       RW.update (Set.delete playerName :: Names -> Names) server)
     (players server !? playerID)

src/Session.hs

@@ -1,12 +1,14 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Session (
-      Status(..)
+      ID
+    , Status(..)
     , T(..)
     , Update
     , open
   ) where
 
+import qualified Hanafuda.ID as Hanafuda (ID)
 import Network.WebSockets (Connection)
 import qualified RW (RW(..))
 
@@ -18,6 +20,7 @@ data T = T {
       connection :: Connection
     , status :: Status
   }
+type ID = Hanafuda.ID T
 type Update = T -> T
 
 instance RW.RW Status T where