hanafuda/server
1
1
Fork 0
Code Issues Pull requests Releases Wiki Activity

Use session keys in the client to remove ambiguity

Browse source
This commit is contained in:
Sasha 2018-04-12 23:01:40 +02:00
parent fab330b71d
commit 59f8751fb6
12 changed files with 355 additions and 237 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/Data.hs
View file

@ -7,4 +7,3 @@ class RW a b where
update :: (a -> a) -> b -> b
set :: a -> b -> b
set = update . const

48
src/Main.hs
View file

@ -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
asks Session.key >>= Session.update . Server.logOut
connected
(onErrorGoto loggedIn)
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

41
src/Message.hs
View file

@ -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

92
src/Player.hs
View file

@ -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
}

92
src/Server.hs
View file

@ -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)

60
src/Session.hs
View file

@ -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})

24
www/connect.js
View file

@ -1,7 +1,8 @@
window.addEventListener('load', function() {
var ws = new WebSocket('ws://' + window.location.hostname + '/play/');
var sessionKey = null;
var lib = Lib(ws);
var room = Room(document.getElementById('players'), lib);
var room = Room(document.getElementById('room'), lib);
var login = Login(document.getElementById('login'), lib);
var debug = document.getElementById('debug');
setTimeout(ping, 20000);
@ -10,7 +11,8 @@ window.addEventListener('load', function() {
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);
@ -26,13 +28,25 @@ window.addEventListener('load', function() {
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});
}
}

5
www/index.html
View file

@ -19,9 +19,10 @@
<input type="button" name="leave" value="Leave"/>
</p>
</form>
<form id="room">
<ul id="players">
<form id="room" class="off">
<ul class="players">
</ul>
<input type="number" hidden name="guest"/>
<input type="submit" name="invite" value="Invite to a game" disabled/>
</form>
<p id="debug"></p>

4
www/lib.js
View file

@ -12,8 +12,8 @@ function Lib(ws) {
}
function insert(obj, t, min, max) {
min = min || 0;
max = max || t.length;
min = min == undefined ? 0 : min;
max = max == undefined ? t.length : max;
if(max - min < 1) {
return min;
}

15
www/login.js
View file

@ -1,5 +1,4 @@
function Login(domElem, lib) {
var login = null;
domElem.addEventListener('submit', function(e) {
e.preventDefault();
lib.send({tag: "LogIn", name: domElem.name.value})
@ -10,21 +9,15 @@ function Login(domElem, lib) {
});
return {
onLogIn: onLogIn,
onLogOut: onLogOut
on: on,
off: off
};
function onLogIn(name) {
if(name == domElem.name.value) {
function on(name) {
domElem.className = "on";
login = name;
}
}
function onLogOut(name) {
if(name == login) {
login = null;
function off() {
domElem.className = "";
}
}
}

97
www/room.js
View file

@ -1,40 +1,109 @@
function Room(domElem, lib) {
var players = {};
var keys = {};
var logins = [];
var session = {
key: null,
loggedIn: false,
selected: null
};
var playersList = domElem.getElementsByClassName('players')[0];
domElem.addEventListener('submit', function(e) {
e.preventDefault();
lib.send({tag: "Invitation", to: parseInt(domElem.guest.value)})
});
return {
populate: populate,
enter: enter,
leave: leave
leave: leave,
name: name
};
function Player(name) {
function Player(key, name) {
var player = {
name: name,
dom: document.createElement('li'),
position: null
};
player.dom.textContent = name;
if(key != session.key) {
player.dom.addEventListener('click', function(e) {
e.preventDefault();
if(session.loggedIn) {
select(key);
}
});
} else {
on();
player.dom.title = "Hey ! That's you !";
}
return player;
}
function populate(playersList) {
lib.clearElement(domElem);
for(var i = 0; i < playersList.length; i++) {
enter(playersList[i].login || "anon");
function populate(playersHash, sessionKey) {
session.key = sessionKey;
lib.clearElement(playersList);
for(var key in playersHash) {
enter(key, playersHash[key] || "anon");
}
}
function enter(name) {
var player = Player(name);
players[name] = player;
function enter(key, name) {
var player = Player(key, name);
keys[key] = name;
players[key] = player;
player.position = lib.insert(name, logins);
beforePlayer = logins[player.position];
domElem.insertBefore(player.dom, beforePlayer && players[beforePlayer].dom);
beforePlayer = players[keys[logins[player.position]]];
playersList.insertBefore(player.dom, beforePlayer && beforePlayer.dom);
logins.splice(player.position, 0, name);
}
function leave(name) {
domElem.removeChild(players[name].dom);
logins.splice(players[name].position, 1);
function leave(key) {
var player = players[key];
if(key == session.key) {
off();
}
if(player != undefined) {
playersList.removeChild(player.dom);
logins.splice(player.position, 1);
delete keys[player.name]
delete players[key];
}
}
function name(key) {
player = players[key];
return player && player.name;
}
function on() {
domElem.className = "";
session.loggedIn = true;
}
function off() {
domElem.className = "off";
session.loggedIn = false;
}
function select(key) {
if(key == domElem.guest.value) {
unselect(players[key].dom);
} else {
if(session.selected) {
unselect(session.selected);
}
players[key].dom.className = "selected";
session.selected = players[key].dom;
domElem.guest.value = key;
domElem.invite.disabled = false;
}
}
function unselect(dom) {
dom.className = "";
domElem.guest.value = "";
domElem.invite.disabled = true;
}
}

11
www/skin.css
View file

@ -10,10 +10,19 @@
display: inline;
}
#players {
#room .players {
min-height: 4em;
border: 1px solid #ccc;
list-style: none;
padding-left: 0;
cursor: pointer;
}
#room.off .players li {
color: #777;
}
#room .players .selected {
background: #92c8f6;
color: #fff;
}