Separate PlayerIDs from SessionIDs and simplify protocol accordingly

hanafuda-webapp.cabal

@@ -41,6 +41,7 @@ executable hanafudapi
                      , http-types
                      , aeson
                      , mtl
+                     , random
                      , saltine
                      , text
                      , vector

src/App.hs

@@ -2,20 +2,16 @@
 module App (
       T
     , Context(..)
-    , connection
     , debug
-    , get
+    , exec
-    , current
     , server
-    , try
+    , session
     , update
-    , update_
   ) where
 
-import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
+import Control.Concurrent (MVar, modifyMVar, readMVar)
 import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
 import Data.Map ((!))
-import Network.WebSockets (Connection)
 import qualified Server (T(..))
 import qualified Session (ID, T(..))
 
@@ -29,35 +25,25 @@ type T a = ReaderT Context IO a
 server :: T Server.T
 server = asks mServer >>= lift . readMVar
 
-get :: Session.ID -> T Session.T
+get :: (Server.T -> a) -> T a
-get sessionID =
+get projector =
-  (! sessionID) . Server.sessions <$> server
+  projector <$> server
 
-current :: T Session.T
+session :: T Session.T
-current = do
+session = do
-  asks sessionID >>= get
+  Context {sessionID} <- ask
-
+  get $ (! sessionID) . Server.sessions
-connection :: T Connection
-connection = Session.connection <$> current
 
 debug :: String -> T ()
 debug message =
   show <$> asks sessionID
   >>= lift . putStrLn . (++ ' ':message)
 
-try :: (Server.T -> Either String Server.T) -> T (Maybe String)
-try f = do
-  Context {mServer} <- ask
-  currentValue <- lift $ takeMVar mServer
-  lift $ case f currentValue of
-    Left message -> putMVar mServer currentValue >> return (Just message)
-    Right updated -> putMVar mServer updated >> return Nothing
-
 {- Not using the previous to minimize the duration mServer gets locked -}
-update :: (Server.T -> (Server.T, a)) -> T a
+exec :: (Server.T -> IO (Server.T, a)) -> T a
-update f = do
+exec f = do
   Context {mServer} <- ask
-  lift $ modifyMVar mServer (return . f)
+  lift $ modifyMVar mServer f
 
-update_ :: (Server.T -> Server.T) -> T ()
+update :: (Server.T -> Server.T) -> T ()
-update_ f = update $ (\x -> (x, ())) . f
+update f = exec $ (\x -> return (x, ())) . f

src/Automaton.hs

@@ -1,86 +1,74 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Automaton (
-    start
+    loop
   ) where
 
-import qualified App (Context(..), T, current, debug, get, server, try, update_)
+import qualified App (Context(..), T, exec, server, session, update)
 import Control.Monad.Reader (asks)
 import qualified Game (new, play)
 import qualified Hanafuda.Message as Message (FromClient(..), T(..))
 import qualified Messaging (
     broadcast, get, notifyPlayers, relay, send, sendTo
   )
-import qualified RW (RW(..))
+import qualified Player (T(..))
-import qualified Server (logIn, logOut, update, players)
+import qualified Server (logIn, logOut, register, room, update)
-import qualified Session (Status(..), T(..), Update)
+import qualified Session (Status, T(..), setPlayer)
 
-receive :: Message.FromClient -> Bool -> App.T ()
+receive :: Message.FromClient -> Session.Status -> App.T ()
 
-receive logIn@(Message.LogIn login) False =
+receive (Message.Hello {Message.name}) Nothing = do
-  asks App.playerID >>= App.try . (Server.logIn login)
+  sessionID <- asks App.sessionID
-  >>= maybe
+  playerID <- App.exec (Server.register sessionID)
-   (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.Status True))
+  room <- Server.room <$> App.server
-   sendError
+  App.update (Server.update sessionID $ Session.setPlayer playerID name)
+  Messaging.send $ Message.Welcome room playerID
 
-receive logOut@Message.LogOut True = do
+receive (Message.Hello {Message.name}) (Just player) = do
+  sessionID <- asks App.sessionID
+  App.update (Server.update sessionID setName)
+  where
+    setName session = session {Session.player = Just $ player {Player.name}}
+
+receive (Message.Tadaima {Message.myID, Message.name}) Nothing = do
+  sessionID <- asks App.sessionID
+  App.update $ Server.logIn name myID sessionID
+  Message.Okaeri . Server.room <$> App.server >>= Messaging.send
+
+receive (Message.Tadaima {}) (Just _) = sendError "You're already logged in"
+
+receive logOut@Message.LogOut (Just _) = do
+  asks App.sessionID >>= App.update . Server.logOut
   Messaging.relay logOut Messaging.broadcast
-  asks App.playerID >>= App.update_ . Server.logOut
-  setSessionStatus (Session.Status False)
 
-receive invitation@(Message.Invitation {Message.to}) True = do
+receive invitation@(Message.Invitation {Message.to}) (Just _) =
-  session <- App.get to
+  Messaging.relay invitation (Messaging.sendTo [to])
-  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
+receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) =
-  session <- App.get to
-  playerID <- asks App.playerID
-  case Session.status session of
-    Session.Waiting for | for == playerID -> do
-      Messaging.relay message $ Messaging.sendTo [to]
-      newStatus <-
   if accept
   then do
-            game <- Game.new (for, to)
+    game <- Game.new (Player.playerID player, to)
     Messaging.notifyPlayers game []
-            return Session.Playing
+  else Messaging.relay answer (Messaging.sendTo [to])
-          else do
-            return $ Session.LoggedIn True
-      App.update_ $ Server.update to (RW.set newStatus :: Session.Update)
-      setSessionStatus newStatus
-    _ -> sendError "They're not waiting for your answer"
 
-receive Session.Playing (Message.Play {Message.move, Message.onGame}) = do
+receive (Message.Play {Message.move, Message.onGame}) (Just player) = do
-  playerID <- asks App.playerID
+  result <- Game.play (Player.playerID player) move onGame
-  result <- Game.play playerID move onGame
   case result of
     Left message -> sendError message
     Right (newGame, logs) -> Messaging.notifyPlayers newGame logs
 
-receive Session.Playing Message.Quit = setSessionStatus (Session.LoggedIn True)
+receive message state =
-
+  sendError $ "Invalid message " ++ show message ++ " in " ++ showState
-receive state _ = sendError $ "Invalid message in state " ++ show state
+  where
+    showState =
+      case state of
+        Nothing -> "disconnected state"
+        Just _ -> "connected state"
 
 sendError :: String -> App.T ()
 sendError = Messaging.send . Message.Error
 
-setSessionStatus :: Session.Status -> App.T ()
-setSessionStatus newStatus = do
-  playerID <- asks App.playerID
-  App.update_ $ Server.update playerID $ (RW.set newStatus :: Session.Update)
-  App.debug $ show newStatus
-
 loop :: App.T ()
 loop = do
   message <- Messaging.get
-  receive message (Status.loggedIn . Session.status <$> App.current)
+  (receive message . Session.player) =<< App.session
-  loop
-
-start :: App.T ()
-start = do
-  App.debug "Initial state"
-  Message.Welcome . Server.players <$> App.server <*> asks App.playerID >>= Messaging.send
   loop

src/Main.hs

@@ -2,8 +2,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main where
 
-import qualified App (Context(..), T, update_)
+import qualified App (Context(..), T, update)
-import qualified Automaton (start)
+import qualified Automaton (loop)
 import qualified Config (listenPort)
 import Control.Concurrent (newMVar, modifyMVar)
 import Control.Exception (finally)
@@ -16,21 +16,21 @@ import Network.Wai (responseLBS)
 import Network.Wai.Handler.Warp (run)
 import Network.Wai.Handler.WebSockets (websocketsOr)
 import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
-import qualified Server (disconnect, new, register)
+import qualified Server (logOut, new, register)
 import qualified Session (open)
 
 exit :: App.T ()
 exit = do
-  asks App.playerID >>= App.update_ . Server.disconnect
+  asks App.sessionID >>= App.update . Server.logOut
-  relay Message.LogOut broadcast
+  Messaging.relay Message.LogOut broadcast
 
 serverApp :: App.T () -> App.T () -> IO ServerApp
 serverApp onEnter onExit = do
   mServer <- newMVar =<< Server.new
   return $ \pending -> do
     session <- Session.open <$> acceptRequest pending
-    playerID <- modifyMVar mServer (return . Server.register session)
+    sessionID <- modifyMVar mServer (Server.register session)
-    let app = App.Context {App.mServer, App.playerID}
+    let app = App.Context {App.mServer, App.sessionID}
     finally
       (runReaderT onEnter app)
       (runReaderT onExit app)
@@ -38,7 +38,7 @@ serverApp onEnter onExit = do
 main :: IO ()
 main = do
   sodiumInit
-  app <- serverApp Automaton.start exit
+  app <- serverApp Automaton.loop exit
   run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
   where
     blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")

src/Messaging.hs

@@ -12,48 +12,59 @@ module Messaging (
     , sendTo
   ) where
 
-import qualified App (Context(..), T, connection, debug, server)
+import qualified App (T, debug, server, session)
-import Control.Monad.Reader (asks, lift)
+import Control.Monad.Reader (lift)
 import Data.Aeson (eitherDecode', encode)
 import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Foldable (forM_)
 import Data.List (intercalate)
-import Data.Map (keys)
+import Data.Map (elems, keys)
+import Data.Maybe (maybeToList)
+import qualified Data.Set as Set (fromList, member)
+import qualified Game (exportGame)
 import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID)
 import Hanafuda.Message (FromClient(..), T(..))
 import qualified Hanafuda.Message as Message (T)
 import Network.WebSockets (receiveData, sendTextData)
-import qualified Game (exportGame)
+import Player (playerID, showDebug)
-import qualified Server (T(..), get)
+import qualified Server (T(..), sessionsWhere)
 import qualified Session (T(..))
 
+sendToSessions :: [Session.T] -> Message.T -> App.T ()
+sendToSessions sessions obj = do
+  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
+  lift . mapM_ (flip sendTextData encoded) $ Session.connection <$> sessions
+  where
+    encoded = encode $ obj
+    recipients = fmap showDebug . maybeToList . Session.player =<< sessions
+
 sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T ()
 sendTo playerIDs obj = do
-  sessions <- getSessions <$> App.server
+  sessions <- Server.sessionsWhere selectedPlayer <$> App.server
-  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
+  sendToSessions (elems sessions) obj
-  lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded
   where
-    encoded = encode $ obj
+    selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs
-    getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs
-    recipients = show <$> playerIDs
 
 send :: Message.T -> App.T ()
 send obj = do
-  sessionID <- asks App.sessionID
+  currentSession <- App.session
-  sendTo [sessionID] obj
+  sendToSessions [currentSession] obj
 
 broadcast :: Message.T -> App.T ()
 broadcast obj =
-  App.server >>= flip sendTo obj . keys . Server.sessions
+  (elems . Server.sessions) <$> App.server >>= flip sendToSessions obj
 
 relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
 relay message f = do
   App.debug "Relaying"
-  (\from -> f $ Relay {from, message}) =<< asks App.sessionID
+  maybe bounce doRelay . Session.player =<< App.session
+  where
+    doRelay player = f $ Relay {from = playerID player, message}
+    bounce = send (Error "Unidentified client can't relay messages")
 
 receive :: App.T FromClient
 receive = do
-  received <- ((lift . receiveData) =<< App.connection)
+  received <- ((lift . receiveData . Session.connection) =<< App.session)
   App.debug $ '>':(unpack received)
   case eitherDecode' received of
     Left errorMessage -> send (Error errorMessage) >> receive

src/Player.hs

@@ -1,11 +1,18 @@
+{-# LANGUAGE NamedFieldPuns #-}
 module Player (
       T(..)
+    , showDebug
   ) where
 
 import Data.Text (Text)
+import Hanafuda.ID (ID(..))
 import Hanafuda.KoiKoi (PlayerID)
+import Text.Printf (printf)
 
 data T = T {
       playerID :: PlayerID
     , name :: Text
   } deriving (Show)
+
+showDebug :: T -> String
+showDebug (T {playerID, name}) = printf "%s (%d)" name (getID playerID)

src/Server.hs

@@ -5,36 +5,40 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Server (
       T(..)
-    , disconnect
     , get
     , logIn
     , logOut
     , new
     , register
+    , room
+    , select
+    , sessionsWhere
     , update
   ) where
 
-import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax)
+import Data.Map (Map, (!), (!?), adjust, delete, insert)
-import qualified Data.Map as Map (empty)
+import qualified Data.Map as Map (empty, lookup, mapMaybeWithKey)
 import Data.Text (Text)
 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, T(..), Update)
+import qualified Session (ID, T(..), setPlayer)
+import System.Random (Random(..))
 
-type Players = Map PlayerID Session.ID
+type SessionIDs = Map PlayerID Session.ID
 type Sessions = Map Session.ID Session.T
 data T = T {
       keys :: Keys.T
-    , players :: Players
+    , sessionIDsByPlayerID :: SessionIDs
     , sessions :: Sessions
   }
 
-instance RW.RW Players T where
+instance RW.RW SessionIDs T where
-  get = players
+  get = sessionIDsByPlayerID
-  set players server = server {players}
+  set sessionIDsByPlayerID server = server {sessionIDsByPlayerID}
 
 instance RW.RW Sessions T where
   get = sessions
@@ -43,14 +47,28 @@ instance RW.RW Sessions T where
 new :: IO T
 new = getKeys >>= \keys -> return $ T {
       keys
-    , players = Map.empty
+    , sessionIDsByPlayerID = Map.empty
     , sessions = Map.empty
   }
 
-register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a)
+room :: T -> Room
-register x server =
+room = fmap Player.name . select (\_ -> Session.player)
-  let newID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
+
-  (RW.update (insert newID x) server, newID)
+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
+
+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
+
+register :: forall a b. (Random a, Ord a, RW.RW (Map a b) T) => b -> T -> IO (T, a)
+register x server = do
+  newID <- randomIO
+  return (RW.update (insert newID x) server, newID)
 
 get :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> T -> b
 get keyID server = (RW.get server :: Map a b) ! keyID
@@ -59,20 +77,15 @@ update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T
 update keyID updator =
   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 -> Session.ID -> T -> T
 logIn name playerID sessionID =
   RW.update (insert playerID sessionID) .
-  update sessionID (RW.set $ Just player :: Session.Update)
+  update sessionID (Session.setPlayer playerID name)
-  where
-    player = Player.T {Player.playerID, Player.name}
 
 logOut :: Session.ID -> T -> T
 logOut sessionID server =
+  RW.update (delete sessionID :: Sessions -> Sessions) $
   case (sessions server !? sessionID) >>= Session.player of
     Nothing -> server
     Just player ->
-      RW.update (delete (Player.playerID player) :: Players -> Players) server
+      RW.update (delete (Player.playerID player) :: SessionIDs -> SessionIDs) server

src/Session.hs

@@ -1,28 +1,31 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
 module Session (
       ID
+    , Status
     , T(..)
     , Update
     , open
+    , setPlayer
   ) where
 
+import Data.Text (Text)
 import qualified Hanafuda.ID as Hanafuda (ID)
+import Hanafuda.KoiKoi (PlayerID)
 import Network.WebSockets (Connection)
-import qualified Player (T)
+import qualified Player (T(..))
-import qualified RW (RW(..))
 
+type ID = Hanafuda.ID T
+type Status = Maybe Player.T
 data T = T {
       connection :: Connection
-    , player :: Maybe Player.T
+    , player :: Status
   }
-type ID = Hanafuda.ID T
 type Update = T -> T
 
-instance RW.RW (Maybe Player.T) T where
+setPlayer :: PlayerID -> Text -> Session.Update
-  get = player
+setPlayer playerID name session = session {
-  set player session = session {player}
+    player = Just $ Player.T {Player.playerID, Player.name}
+  }
 
 open :: Connection -> T
 open connection = T {