Separate PlayerIDs from SessionIDs and simplify protocol accordingly
This commit is contained in:
parent
50b24a0db6
commit
bfb4837352
8 changed files with 151 additions and 142 deletions
|
@ -41,6 +41,7 @@ executable hanafudapi
|
|||
, http-types
|
||||
, aeson
|
||||
, mtl
|
||||
, random
|
||||
, saltine
|
||||
, text
|
||||
, vector
|
||||
|
|
44
src/App.hs
44
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
|
||||
|
|
102
src/Automaton.hs
102
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
|
||||
|
|
16
src/Main.hs
16
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")
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 {
|
||||
|
|
Loading…
Reference in a new issue