Add a Player type back and slowly start separating SessionIDs (temporary) and PlayerID (permanent)

hanafuda-webapp.cabal

@@ -24,9 +24,10 @@ executable hanafudapi
   other-modules:       App
                      , Automaton
                      , Config
+                     , Game
                      , Keys
                      , Messaging
-                     , Game
+                     , Player
                      , RW
                      , Server
                      , Session

src/App.hs

@@ -15,14 +15,13 @@ module App (
 import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
 import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
 import Data.Map ((!))
-import Hanafuda.KoiKoi (PlayerID)
 import Network.WebSockets (Connection)
 import qualified Server (T(..))
-import qualified Session (T(..))
+import qualified Session (ID, T(..))
 
 data Context = Context {
       mServer :: MVar Server.T
-    , playerID :: PlayerID
+    , sessionID :: Session.ID
   }
 
 type T a = ReaderT Context IO a
@@ -30,20 +29,20 @@ type T a = ReaderT Context IO a
 server :: T Server.T
 server = asks mServer >>= lift . readMVar
 
-get :: PlayerID -> T Session.T
+get :: Session.ID -> T Session.T
-get playerID =
+get sessionID =
-  (! playerID) . Server.sessions <$> server
+  (! sessionID) . Server.sessions <$> server
 
 current :: T Session.T
 current = do
-  asks playerID >>= get
+  asks sessionID >>= get
 
 connection :: T Connection
 connection = Session.connection <$> current
 
 debug :: String -> T ()
 debug message =
-  show <$> asks playerID
+  show <$> asks sessionID
   >>= lift . putStrLn . (++ ' ':message)
 
 try :: (Server.T -> Either String Server.T) -> T (Maybe String)

src/Messaging.hs

@@ -39,8 +39,8 @@ sendTo playerIDs obj = do
 
 send :: Message.T -> App.T ()
 send obj = do
-  playerID <- asks App.playerID
+  sessionID <- asks App.sessionID
-  sendTo [playerID] obj
+  sendTo [sessionID] obj
 
 broadcast :: Message.T -> App.T ()
 broadcast obj =
@@ -49,7 +49,7 @@ broadcast obj =
 relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
 relay message f = do
   App.debug "Relaying"
-  (\from -> f $ Relay {from, message}) =<< asks App.playerID
+  (\from -> f $ Relay {from, message}) =<< asks App.sessionID
 
 receive :: App.T FromClient
 receive = do

src/Player.hs

@@ -0,0 +1,11 @@
+module Player (
+    T(..)
+  ) where
+
+import Data.Text (Text)
+import Hanafuda.KoiKoi (PlayerID)
+
+data T = T {
+      playerID :: PlayerID
+    , name :: Text
+  } deriving (Show)

src/Server.hs

@@ -16,31 +16,23 @@ module Server (
 
 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 (Room)
 import Keys (getKeys)
 import qualified Keys (T)
+import qualified Player (T(..))
 import qualified RW (RW(..))
-import qualified Session (ID, Status(..), T(..), Update)
+import qualified Session (ID, T(..), Update)
 
-type Names = Set Text
+type Players = Map PlayerID Session.ID
 type Sessions = Map Session.ID Session.T
 data T = T {
-      names :: Names
+      keys :: Keys.T
-    , players :: Room
+    , players :: Players
     , sessions :: Sessions
-    , keys :: Keys.T
   }
 
-instance RW.RW Names T where
+instance RW.RW Players T where
-  get = names
-  set names server = server {names}
-
-instance RW.RW Room T where
   get = players
   set players server = server {players}
 
@@ -50,43 +42,37 @@ instance RW.RW Sessions T where
 
 new :: IO T
 new = getKeys >>= \keys -> return $ T {
-      names = Set.empty
+      keys
     , players = Map.empty
     , sessions = Map.empty
-    , keys
   }
 
 register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a)
 register x server =
-  let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
+  let newID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
-  (RW.update (insert playerID x) server, playerID)
+  (RW.update (insert newID x) server, newID)
 
 get :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> T -> b
-get playerID server = (RW.get server :: Map a b) ! playerID
+get keyID server = (RW.get server :: Map a b) ! keyID
 
 update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T
-update playerID updator =
+update keyID updator =
-  RW.update (adjust updator playerID :: Map a b -> Map a b)
+  RW.update (adjust updator keyID :: Map a b -> Map a b)
 
 disconnect :: Session.ID -> T -> T
 disconnect sessionID =
   RW.update (delete sessionID :: Sessions -> Sessions) . logOut sessionID
 
-logIn :: Text -> PlayerID -> T -> Either String T
+logIn :: Text -> PlayerID -> Session.ID -> T -> T
-logIn name playerID server =
+logIn name playerID sessionID =
-  RW.update (Set.insert name) .
+  RW.update (insert playerID sessionID) .
-  RW.update (insert playerID name) .
+  update sessionID (RW.set $ Just player :: Session.Update)
-  update playerID (RW.set $ Session.Status True :: Session.Update) <$>
+  where
-  if name `member` names server
+    player = Player.T {Player.playerID, Player.name}
-    then Left "This name is already registered"
-    else Right server
 
-logOut :: PlayerID -> T -> T
+logOut :: Session.ID -> T -> T
-logOut playerID server =
+logOut sessionID server =
-  maybe
+  case (sessions server !? sessionID) >>= Session.player of
-    server
+    Nothing -> server
-    (\playerName ->
+    Just player ->
-      RW.update (delete playerID :: Room -> Room) $
+      RW.update (delete (Player.playerID player) :: Players -> Players) server
-      update playerID (RW.set $ Session.Status False :: Session.Update) $
-      RW.update (Set.delete playerName :: Names -> Names) server)
-    (players server !? playerID)

src/Session.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Session (
       ID
-    , Status(..)
     , T(..)
     , Update
     , open
@@ -10,25 +10,22 @@ module Session (
 
 import qualified Hanafuda.ID as Hanafuda (ID)
 import Network.WebSockets (Connection)
+import qualified Player (T)
 import qualified RW (RW(..))
 
-newtype Status = Status {
-    loggedIn :: Bool
-  } deriving (Show)
-
 data T = T {
       connection :: Connection
-    , status :: Status
+    , player :: Maybe Player.T
   }
 type ID = Hanafuda.ID T
 type Update = T -> T
 
-instance RW.RW Status T where
+instance RW.RW (Maybe Player.T) T where
-  get = status
+  get = player
-  set status session = session {status}
+  set player session = session {player}
 
 open :: Connection -> T
 open connection = T {
       connection
-    , status = Status False
+    , player = Nothing
   }