Separate PlayerIDs from SessionIDs and simplify protocol accordingly

2019-11-12 23:25:00 +01:00 · 2019-11-12 23:25:00 +01:00 · bfb4837352
parent 50b24a0db6
commit bfb4837352
8 changed files with 151 additions and 142 deletions
--- a/hanafuda-webapp.cabal
+++ b/hanafuda-webapp.cabal
@ -41,6 +41,7 @@ executable hanafudapi
                     , http-types
                     , aeson
                     , mtl
+                     , random
                     , saltine
                     , text
                     , vector
--- a/src/App.hs
+++ b/src/App.hs
@ -2,20 +2,16 @@
 module App (
      T
    , Context(..)
-    , connection
    , debug
-    , get
-    , current
+    , exec
    , 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 sessionID =
-  (! sessionID) . Server.sessions <$> server
+get :: (Server.T -> a) -> T a
+get projector =
+  projector <$> server

-current :: T Session.T
-current = do
-  asks sessionID >>= get
-
-connection :: T Connection
-connection = Session.connection <$> current
+session :: T Session.T
+session = do
+  Context {sessionID} <- ask
+  get $ (! sessionID) . Server.sessions

 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
-update f = do
+exec :: (Server.T -> IO (Server.T, a)) -> T a
+exec f = do
  Context {mServer} <- ask
-  lift $ modifyMVar mServer (return . f)
+  lift $ modifyMVar mServer f

-update_ :: (Server.T -> Server.T) -> T ()
-update_ f = update $ (\x -> (x, ())) . f
+update :: (Server.T -> Server.T) -> T ()
+update f = exec $ (\x -> return (x, ())) . f
--- a/src/Automaton.hs
+++ b/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 Server (logIn, logOut, update, players)
-import qualified Session (Status(..), T(..), Update)
+import qualified Player (T(..))
+import qualified Server (logIn, logOut, register, room, 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 =
-  asks App.playerID >>= App.try . (Server.logIn login)
-  >>= maybe
-   (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.Status True))
-   sendError
+receive (Message.Hello {Message.name}) Nothing = do
+  sessionID <- asks App.sessionID
+  playerID <- App.exec (Server.register sessionID)
+  room <- Server.room <$> App.server
+  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
-  session <- App.get to
-  if Session.loggedIn $ Session.status session
+receive invitation@(Message.Invitation {Message.to}) (Just _) =
+  Messaging.relay invitation (Messaging.sendTo [to])
+
+receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) =
+  if accept
  then do
-    from <- asks App.playerID
-    App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update))
-  else sendError "They just left"
+    game <- Game.new (Player.playerID player, to)
+    Messaging.notifyPlayers game []
+  else Messaging.relay answer (Messaging.sendTo [to])

-receive (Session.LoggedIn True) message@(Message.Answer {Message.accept}) = do
-  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)
-            Messaging.notifyPlayers game []
-            return Session.Playing
-          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
-  playerID <- asks App.playerID
-  result <- Game.play playerID move onGame
+receive (Message.Play {Message.move, Message.onGame}) (Just player) = do
+  result <- Game.play (Player.playerID player) 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 state _ = sendError $ "Invalid message in state " ++ show state
+receive message state =
+  sendError $ "Invalid message " ++ show message ++ " in " ++ showState
+  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)
-  loop
-
-start :: App.T ()
-start = do
-  App.debug "Initial state"
-  Message.Welcome . Server.players <$> App.server <*> asks App.playerID >>= Messaging.send
+  (receive message . Session.player) =<< App.session
  loop
--- a/src/Main.hs
+++ b/src/Main.hs
@ -2,8 +2,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main where

-import qualified App (Context(..), T, update_)
-import qualified Automaton (start)
+import qualified App (Context(..), T, update)
+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
-  relay Message.LogOut broadcast
+  asks App.sessionID >>= App.update . Server.logOut
+  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)
-    let app = App.Context {App.mServer, App.playerID}
+    sessionID <- modifyMVar mServer (Server.register session)
+    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")
--- a/src/Messaging.hs
+++ b/src/Messaging.hs
@ -12,48 +12,59 @@ module Messaging (
    , sendTo
  ) where

-import qualified App (Context(..), T, connection, debug, server)
-import Control.Monad.Reader (asks, lift)
+import qualified App (T, debug, server, session)
+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 qualified Server (T(..), get)
+import Player (playerID, showDebug)
+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
-  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
-  lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded
+  sessions <- Server.sessionsWhere selectedPlayer <$> App.server
+  sendToSessions (elems sessions) obj
  where
-    encoded = encode $ obj
-    getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs
-    recipients = show <$> playerIDs
+    selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs

 send :: Message.T -> App.T ()
 send obj = do
-  sessionID <- asks App.sessionID
-  sendTo [sessionID] obj
+  currentSession <- App.session
+  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
--- a/src/Player.hs
+++ b/src/Player.hs
@ -1,11 +1,18 @@
+{-# LANGUAGE NamedFieldPuns #-}
 module Player (
-    T(..)
+      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)
--- a/src/Server.hs
+++ b/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 qualified Data.Map as Map (empty)
+import Data.Map (Map, (!), (!?), adjust, delete, insert)
+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
-  get = players
-  set players server = server {players}
+instance RW.RW SessionIDs T where
+  get = sessionIDsByPlayerID
+  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)
-register x server =
-  let newID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
-  (RW.update (insert newID x) server, newID)
+room :: T -> Room
+room = fmap Player.name . select (\_ -> Session.player)
+
+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)
-  where
-    player = Player.T {Player.playerID, Player.name}
+  update sessionID (Session.setPlayer playerID 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
--- a/src/Session.hs
+++ b/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 RW (RW(..))
+import qualified Player (T(..))

+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
-  get = player
-  set player session = session {player}
+setPlayer :: PlayerID -> Text -> Session.Update
+setPlayer playerID name session = session {
+    player = Just $ Player.T {Player.playerID, Player.name}
+  }

 open :: Connection -> T
 open connection = T {