From 59f8751fb62cb8a20fb24dd003489edd0ba14b41 Mon Sep 17 00:00:00 2001 From: Sasha Date: Thu, 12 Apr 2018 23:01:40 +0200 Subject: [PATCH] Use session keys in the client to remove ambiguity --- src/Data.hs | 1 - src/Main.hs | 50 ++++++++++++------- src/Message.hs | 41 ++++++++-------- src/Player.hs | 92 +++++++++++++++++------------------ src/Server.hs | 92 +++++++++++++++++++---------------- src/Session.hs | 60 ++++++++++++----------- www/connect.js | 36 +++++++++----- www/index.html | 27 ++++++----- www/lib.js | 28 +++++------ www/login.js | 27 ++++------- www/room.js | 127 ++++++++++++++++++++++++++++++++++++++----------- www/skin.css | 11 ++++- 12 files changed, 355 insertions(+), 237 deletions(-) diff --git a/src/Data.hs b/src/Data.hs index cb9a9d8..a7bec41 100644 --- a/src/Data.hs +++ b/src/Data.hs @@ -7,4 +7,3 @@ class RW a b where update :: (a -> a) -> b -> b set :: a -> b -> b set = update . const - diff --git a/src/Main.hs b/src/Main.hs index eabe1b3..9acd7c5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,11 +7,12 @@ import Network.HTTP.Types.Status (badRequest400) import Network.WebSockets (defaultConnectionOptions) import Network.Wai.Handler.WebSockets (websocketsOr) import Network.Wai (responseLBS) +import Control.Monad.Reader (asks) import qualified Config (listenPort) -import qualified Player (Login(..), T(..)) -import qualified Server (logIn, logOut, disconnect) -import qualified Session (App, debug, get, player, serve, update) -import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send) +import qualified Player (Session(..), Status(..)) +import qualified Server (logIn, logOut, disconnect, setStatus) +import qualified Session (App, T(..), current, debug, get, serve, server, try, update) +import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send, sendTo) type Vertex = Session.App () type Edges = Message.FromClient -> Vertex @@ -27,7 +28,7 @@ newVertex name = do enter :: Vertex enter = do Session.debug "Initial state" - Session.get id >>= (Message.send . Message.Welcome) + Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send connected onErrorGoto :: Vertex -> String -> Session.App () @@ -38,7 +39,7 @@ connected :: Vertex connected = newVertex "Connected" edges where edges logIn@(Message.LogIn login) = - Session.update (Server.logIn login) + asks Session.key >>= Session.try . (Server.logIn login) >>= maybe (Message.relay logIn Message.broadcast >> loggedIn) (onErrorGoto connected) @@ -49,20 +50,37 @@ loggedIn = newVertex "Logged in" edges where edges logOut@Message.LogOut = do Message.relay logOut Message.broadcast - Session.update Server.logOut - >>= maybe - connected - (onErrorGoto loggedIn) + asks Session.key >>= Session.update . Server.logOut + connected + edges invitation@(Message.Invitation {Message.to}) = do + session <- Session.get to + case Player.status session of + Player.LoggedIn True -> do + key <- asks Session.key + Session.update (Server.setStatus (Player.Waiting to) key) + Session.update (Server.setStatus (Player.Answering key) to) + (Message.relay invitation $ Message.sendTo (to, session)) + loggedIn + _ -> onErrorGoto loggedIn "They just left" + edges (Message.Answer {Message.accept}) = do + current <- Session.current + case Player.status current of + Player.Answering to -> do + session <- Session.get to + key <- asks Session.key + case Player.status session of + Player.Waiting for | for == key -> + if accept + then Session.debug "Yeah ! Let's start a game" >> loggedIn + else Session.debug "Oh they said no" >> loggedIn + _ -> onErrorGoto loggedIn "They're not waiting for your answer" + _ -> onErrorGoto loggedIn "You haven't been invited yet" edges _ = loggedIn exit :: Vertex exit = do - leaving <- Player.login <$> Session.player - _ <- Session.update Server.disconnect -- ignoring never-occuring error - case leaving of - Player.Login from -> Message.broadcast $ - Message.Relay {Message.from, Message.message = Message.LogOut} - _ -> return () + asks Session.key >>= Session.update . Server.disconnect + Message.relay Message.LogOut Message.broadcast main :: IO () main = do diff --git a/src/Message.hs b/src/Message.hs index f85edf5..4490067 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -7,23 +7,25 @@ module Message ( , receive , relay , send + , sendTo ) where +import Data.Map (toList) import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions) import Network.WebSockets (receiveData, sendTextData) import Data.ByteString.Lazy.Char8 (unpack) import Control.Monad (mapM_) -import Control.Monad.Reader (lift) -import qualified Player (Login(..), Name, T(..)) +import Control.Monad.Reader (asks, lift) +import qualified Player (Key, Name, Session(..)) import qualified Server (T(..)) -import qualified Session (App, connection, debug, get, player) +import qualified Session (App, T(..), connection, current, debug, server) import qualified Hanafuda.KoiKoi as KoiKoi (Move(..)) import GHC.Generics (Generic) import Game () data FromClient = Answer {accept :: Bool} - | Invitation {to :: Player.Name} + | Invitation {to :: Player.Key} | LogIn {name :: Player.Name} | LogOut | Game {move :: KoiKoi.Move} @@ -36,8 +38,8 @@ instance FromJSON FromClient where parseJSON = genericParseJSON defaultOptions data T = - Relay {from :: Player.Name, message :: FromClient} - | Welcome {room :: Server.T} + Relay {from :: Player.Key, message :: FromClient} + | Welcome {room :: Server.T, key :: Player.Key} | Pong | Error {error :: String} deriving (Generic) @@ -45,31 +47,28 @@ data T = instance ToJSON T where toEncoding = genericToEncoding defaultOptions -sendTo :: T -> Player.T -> Session.App () -sendTo obj player = do - Session.debug $ '(' : playerLogin ++ ") <" ++ (unpack encoded) - lift $ sendTextData (Player.connection player) $ encoded +sendTo :: (Player.Key, Player.Session) -> T -> Session.App () +sendTo (key, session) obj = do + Session.debug $ '(' : show key ++ ") <" ++ (unpack encoded) + lift $ sendTextData (Player.connection session) $ encoded where encoded = encode $ obj - playerLogin = unpack $ encode $ Player.login player send :: T -> Session.App () -send obj = - (obj `sendTo`) =<< Session.player +send obj = do + key <- asks Session.key + session <- Session.current + sendTo (key, session) obj broadcast :: T -> Session.App () broadcast obj = - Session.get Server.bySessionId - >>= mapM_ (obj `sendTo`) + (toList . Server.sessions) <$> Session.server + >>= mapM_ (flip sendTo obj) relay :: FromClient -> (T -> Session.App ()) -> Session.App () -relay message f = +relay message f = do Session.debug "Relaying" - >> Session.player >>= (ifLoggedIn . Player.login) - >> Session.debug "Relayed" - where - ifLoggedIn Player.Anonymous = return () - ifLoggedIn (Player.Login from) = f $ Relay {from, message} + (\from -> f $ Relay {from, message}) =<< asks Session.key receive :: Session.App FromClient receive = do diff --git a/src/Player.hs b/src/Player.hs index e0f873a..a0af7e5 100644 --- a/src/Player.hs +++ b/src/Player.hs @@ -1,70 +1,72 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} module Player ( - Login(..) - , Name(..) + Key(..) + , Name + , Session(..) , Status(..) , T(..) , new + , openSession ) where -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Aeson (FromJSON(..), ToJSON(..), (.=), Value(..), genericToEncoding, object, pairs) -import qualified JSON (defaultOptions, singleLCField) +import Data.Text (Text, pack) +import Data.Aeson (FromJSON(..), ToJSON(..), ToJSONKey(..), genericToEncoding) +import Data.Aeson.Types (toJSONKeyText) +import qualified JSON (defaultOptions) import qualified Data (RW(..)) import Network.WebSockets (Connection) import GHC.Generics +newtype Key = Key Int deriving (Eq, Ord, Read, Show, Generic) newtype Name = Name Text deriving (Eq, Ord, Generic) -data Login = Anonymous | Login Name + +data T = T { + key :: Key + , name :: Name + } + deriving (Generic) + +instance Data.RW Key T where + update f player@(T {key}) = player {key = f key} + +instance Data.RW Name T where + update f player@(T {name}) = player {name = f name} + +instance FromJSON Key +instance ToJSON Key where + toEncoding = genericToEncoding JSON.defaultOptions + +instance ToJSONKey Key where + toJSONKey = toJSONKeyText (pack . \(Key n) -> show n) + +instance FromJSON Name +instance ToJSON Name where + toEncoding = genericToEncoding JSON.defaultOptions + +instance ToJSON T where + toEncoding = genericToEncoding JSON.defaultOptions data Status = LoggedIn Bool - | Answering Name - | Waiting Name + | Answering Key + | Waiting Key deriving (Generic) -data T = T { +data Session = Session { connection :: Connection - , login :: Login , status :: Status } -instance Data.RW Login T where - update f player@(T {login}) = player {login = f login} +instance Data.RW Status Session where + update f session@(Session {status}) = session {status = f status} -instance Data.RW Status T where - update f player@(T {status}) = player {status = f status} +new :: Key -> Name -> T +new key name = T {key, name} -instance ToJSON Name where - toEncoding = genericToEncoding JSON.defaultOptions -instance FromJSON Name - -instance ToJSON Login where - toJSON Anonymous = toJSON Null - toJSON (Login name) = toJSON name - toEncoding Anonymous = toEncoding Null - toEncoding (Login name) = toEncoding name - -instance FromJSON Login where - parseJSON Null = return Anonymous - parseJSON s = Login <$> parseJSON s - -instance ToJSON Status where - toEncoding = genericToEncoding JSON.singleLCField - -instance ToJSON T where - toJSON (T {login, status}) = object ["login" .= login, "status" .= status] - toEncoding (T {login, status}) = pairs ( - "login" .= login <> "status" .= status - ) - -new :: Connection -> T -new connection = T {connection, login = Anonymous, status = LoggedIn False} +openSession :: Connection -> Session +openSession connection = Session { + connection + , status = LoggedIn False + } diff --git a/src/Server.hs b/src/Server.hs index 4519922..f6a1450 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -2,71 +2,79 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} module Server ( - SessionId - , T(..) + T(..) , disconnect , join , logIn , logOut , new + , setStatus ) where -import Data.Vector (fromList) -import Data.Aeson (ToJSON(..), Value(Array)) -import Data.Map ((!), (!?), Map, adjust, delete, elems, empty, insert, lookupMax) +import Data.Map ((!?), Map, adjust, delete, insert, lookupMax) +import qualified Data.Map as Map (empty) +import Data.Aeson (ToJSON(..)) import qualified Data (RW(..)) -import qualified Player (Login(..), Name(..), T(..)) +import qualified Player (Key(..), Name, Session(..), Status(..)) -newtype SessionId = SessionId Int deriving (Eq, Ord, Read, Show) -type Players = Map SessionId Player.T -type SessionIds = Map Player.Name SessionId +type Keys = Map Player.Name Player.Key +type Names = Map Player.Key Player.Name +type Sessions = Map Player.Key Player.Session data T = T { - byName :: SessionIds - , bySessionId :: Players + keys :: Keys + , names :: Names + , sessions :: Sessions } -instance Data.RW SessionIds T where - update f server@(T {byName}) = server {byName = f byName} +instance Data.RW Keys T where + update f server@(T {keys}) = server {keys = f keys} -instance Data.RW Players T where - update f server@(T {bySessionId}) = server {bySessionId = f bySessionId} +instance Data.RW Names T where + update f server@(T {names}) = server {names = f names} -loggedInPlayers :: T -> [Player.T] -loggedInPlayers (T {byName, bySessionId}) = - [(bySessionId ! sessionId) | sessionId <- elems byName] +instance Data.RW Sessions T where + update f server@(T {sessions}) = server {sessions = f sessions} instance ToJSON T where - toJSON = Array . fromList . (toJSON <$>) . loggedInPlayers - toEncoding = toEncoding . loggedInPlayers + toJSON = toJSON . names + toEncoding = toEncoding . names new :: T new = T { - byName = empty - , bySessionId = empty + keys = Map.empty + , names = Map.empty + , sessions = Map.empty } -join :: Player.T -> T -> IO (T, SessionId) -join player server@(T {bySessionId}) = - return (Data.update (insert sessionId player) server, sessionId) +join :: Player.Session -> T -> IO (T, Player.Key) +join session server@(T {sessions}) = + return (Data.update (insert key session) server, key) where - sessionId = SessionId $ maybe 0 (\(SessionId n, _) -> n+1) $ lookupMax bySessionId + key = Player.Key $ maybe 0 (\(Player.Key n, _) -> n+1) $ lookupMax sessions -disconnect :: SessionId -> T -> Either String T -disconnect sessionId server = - Data.update (delete sessionId :: Players -> Players) <$> logOut sessionId server +disconnect :: Player.Key -> T -> T +disconnect key = + Data.update (delete key :: Sessions -> Sessions) . logOut key -logIn :: Player.Name -> SessionId -> T -> Either String T -logIn name sessionId server = - Data.update (adjust (Data.set (Player.Login name) :: Player.T -> Player.T) sessionId) <$> - Data.update (insert name sessionId) <$> - maybe (Right server) (\_ -> Left "This name is already registered") maybeName - where - maybeName = byName server !? name +logIn :: Player.Name -> Player.Key -> T -> Either String T +logIn name key server = + Data.update (insert name key) . + Data.update (insert key name) . + setStatus (Player.LoggedIn True) key <$> + maybe (Right server) (\_-> Left "This name is already registered") (keys server !? name) -logOut :: SessionId -> T -> Either String T -logOut sessionId server@(T {bySessionId}) = - Right $ Data.update (adjust (Data.set Player.Anonymous :: Player.T -> Player.T) sessionId) $ - (case Player.login $ bySessionId ! sessionId of - (Player.Login name) -> Data.update (delete name :: SessionIds -> SessionIds) server - Player.Anonymous -> server) +logOut :: Player.Key -> T -> T +logOut key server = + maybe + server + (\name -> + Data.update (delete key :: Names -> Names) $ + setStatus (Player.LoggedIn False) key $ + Data.update (delete name :: Keys -> Keys) server) + (names server !? key) + +setStatus :: Player.Status -> Player.Key -> T -> T +setStatus status key = + Data.update (adjust (Data.set status) key :: Sessions -> Sessions) diff --git a/src/Session.hs b/src/Session.hs index d142da5..ca9ef56 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -5,8 +5,10 @@ module Session ( , connection , debug , get - , player + , current , serve + , server + , try , update ) where @@ -15,50 +17,54 @@ import Control.Concurrent (MVar, newMVar, modifyMVar, putMVar, readMVar, takeMVa import Control.Exception (finally) import Control.Monad.Reader (ReaderT(..), ask, asks, lift) import Network.WebSockets (Connection, ServerApp, acceptRequest) -import qualified Player (T(..), new) -import qualified Server (SessionId, T(..), join, new) +import qualified Player (Key, Session(..), openSession) +import qualified Server (T(..), join, new) data T = T { - server :: MVar Server.T - , key :: Server.SessionId + mServer :: MVar Server.T + , key :: Player.Key } type App a = ReaderT T IO a -get :: (Server.T -> a) -> App a -get f = - asks server - >>= lift . (f <$>) . readMVar +server :: App Server.T +server = asks mServer >>= lift . readMVar -player :: App Player.T -player = do - sId <- asks key - get ((! sId) . Server.bySessionId) +get :: Player.Key -> App Player.Session +get key = + (! key) . Server.sessions <$> server + +current :: App Player.Session +current = do + asks key >>= get connection :: App Connection -connection = Player.connection <$> player +connection = Player.connection <$> current debug :: String -> App () debug message = - show <$> asks Session.key + show <$> asks key >>= lift . putStrLn . (++ ' ':message) -update :: (Server.SessionId -> Server.T -> Either String Server.T) -> App (Maybe String) -update f = do - T {server, key} <- ask - currentValue <- lift $ takeMVar server - lift $ case f key currentValue of - Left message -> putMVar server currentValue >> return (Just message) - Right updated -> putMVar server updated >> return Nothing +try :: (Server.T -> Either String Server.T) -> App (Maybe String) +try f = do + T {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 + +update :: (Server.T -> Server.T) -> App () +update f = try (Right . f) >> return () serve :: App () -> App () -> IO ServerApp serve onEnter onExit = do - server <- newMVar Server.new + mServer <- newMVar Server.new return $ \pending -> do key <- acceptRequest pending - >>= return . Player.new - >>= modifyMVar server . Server.join + >>= return . Player.openSession + >>= modifyMVar mServer . Server.join finally - (runReaderT onEnter $ T {server, key}) - (runReaderT onExit $ T {server, key}) + (runReaderT onEnter $ T {mServer, key}) + (runReaderT onExit $ T {mServer, key}) diff --git a/www/connect.js b/www/connect.js index 41a666e..1cca538 100644 --- a/www/connect.js +++ b/www/connect.js @@ -1,16 +1,18 @@ window.addEventListener('load', function() { - var ws = new WebSocket('ws://' + window.location.hostname + '/play/'); - var lib = Lib(ws); - var room = Room(document.getElementById('players'), lib); + var ws = new WebSocket('ws://' + window.location.hostname + '/play/'); + var sessionKey = null; + var lib = Lib(ws); + var room = Room(document.getElementById('room'), lib); var login = Login(document.getElementById('login'), lib); var debug = document.getElementById('debug'); setTimeout(ping, 20000); - ws.addEventListener('message', function(event) { - var o = JSON.parse(event.data); + ws.addEventListener('message', function(event) { + var o = JSON.parse(event.data); switch(o.tag) { case "Welcome": - room.populate(o.room); + sessionKey = o.key; + room.populate(o.room, sessionKey); break; case "Pong": setTimeout(ping, 10000); @@ -19,20 +21,32 @@ window.addEventListener('load', function() { relayedMessage(o) break; default: - debug.textContent = event.data; + debug.textContent = event.data; } - }); + }); function relayedMessage(o) { switch(o.message.tag) { case "LogIn": - room.enter(o.from); - login.onLogIn(o.from); + room.enter(o.from, o.message.name); + if(o.from == sessionKey) { + login.on(o.from); + } break; case "LogOut": room.leave(o.from); - login.onLogOut(o.from); + if(o.from == sessionKey) { + login.off(o.from); + } break; + case "Invitation": + var name = room.name(o.from); + var accept = false; + // invitations should come only from known players, in doubt say «no» + if(name) { + accept = confirm(name + " has invited you to a game"); + } + lib.send({tag: "Answer", accept: accept}); } } diff --git a/www/index.html b/www/index.html index c0edf0a..a3674d6 100644 --- a/www/index.html +++ b/www/index.html @@ -1,15 +1,15 @@ - - KoiKoi - - - - - - - -

Hanafuda

+ + KoiKoi + + + + + + + +

Hanafuda

@@ -19,11 +19,12 @@

-
-