First draft, basic session handling
This commit is contained in:
commit
fab330b71d
20 changed files with 687 additions and 0 deletions
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
|
@ -0,0 +1 @@
|
|||
/dist/*
|
5
ChangeLog.md
Normal file
5
ChangeLog.md
Normal file
|
@ -0,0 +1,5 @@
|
|||
# Revision history for hanafudapi
|
||||
|
||||
## 0.1.0.0 -- 2018-03-17
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
30
LICENSE
Normal file
30
LICENSE
Normal file
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2018, Sasha
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Sasha nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
48
hanafudapi.cabal
Normal file
48
hanafudapi.cabal
Normal file
|
@ -0,0 +1,48 @@
|
|||
-- Initial hanafudapi.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: hanafudapi
|
||||
version: 0.1.0.0
|
||||
synopsis: An API for the Haskell hanafuda library
|
||||
-- description:
|
||||
homepage: https://framagit.org/hanafuda
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Sasha
|
||||
maintainer: sasha+frama@marvid.fr
|
||||
-- copyright:
|
||||
category: Web
|
||||
build-type: Simple
|
||||
extra-source-files: ChangeLog.md
|
||||
cabal-version: >=1.10
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://framagit.org/hanafuda/api
|
||||
|
||||
executable hanafudapi
|
||||
main-is: Main.hs
|
||||
other-modules: Config
|
||||
, Message
|
||||
, Game
|
||||
, JSON
|
||||
, Data
|
||||
, Player
|
||||
, Server
|
||||
, Session
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.10 && <4.11
|
||||
, bytestring
|
||||
, containers
|
||||
, hanafuda
|
||||
, http-types
|
||||
, aeson
|
||||
, mtl
|
||||
, text
|
||||
, vector
|
||||
, wai
|
||||
, wai-websockets
|
||||
, warp
|
||||
, websockets
|
||||
ghc-options: -Wall -fno-warn-orphans
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
6
src/Config.hs
Normal file
6
src/Config.hs
Normal file
|
@ -0,0 +1,6 @@
|
|||
module Config (
|
||||
listenPort
|
||||
) where
|
||||
|
||||
listenPort :: Int
|
||||
listenPort = 3000
|
10
src/Data.hs
Normal file
10
src/Data.hs
Normal file
|
@ -0,0 +1,10 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Data (
|
||||
RW(..)
|
||||
) where
|
||||
|
||||
class RW a b where
|
||||
update :: (a -> a) -> b -> b
|
||||
set :: a -> b -> b
|
||||
set = update . const
|
||||
|
19
src/Game.hs
Normal file
19
src/Game.hs
Normal file
|
@ -0,0 +1,19 @@
|
|||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Game where
|
||||
|
||||
import Hanafuda (Card(..))
|
||||
import Hanafuda.KoiKoi (Move(..))
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding)
|
||||
import qualified JSON (singleLCField)
|
||||
import GHC.Generics
|
||||
|
||||
deriving instance Generic Card
|
||||
deriving instance Generic Move
|
||||
|
||||
instance FromJSON Card
|
||||
instance ToJSON Card
|
||||
|
||||
instance FromJSON Move
|
||||
instance ToJSON Move where
|
||||
toEncoding = genericToEncoding JSON.singleLCField
|
21
src/JSON.hs
Normal file
21
src/JSON.hs
Normal file
|
@ -0,0 +1,21 @@
|
|||
module JSON (
|
||||
defaultOptions
|
||||
, singleLCField
|
||||
) where
|
||||
|
||||
import Data.Char (toLower)
|
||||
import Data.Aeson (
|
||||
Options(..)
|
||||
, SumEncoding(..)
|
||||
, defaultOptions
|
||||
)
|
||||
|
||||
first :: (a -> a) -> [a] -> [a]
|
||||
first _ [] = []
|
||||
first f (x:xs) = f x:xs
|
||||
|
||||
singleLCField :: Options
|
||||
singleLCField = defaultOptions {
|
||||
constructorTagModifier = (toLower `first`)
|
||||
, sumEncoding = ObjectWithSingleField
|
||||
}
|
72
src/Main.hs
Normal file
72
src/Main.hs
Normal file
|
@ -0,0 +1,72 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module Main where
|
||||
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Network.HTTP.Types.Status (badRequest400)
|
||||
import Network.WebSockets (defaultConnectionOptions)
|
||||
import Network.Wai.Handler.WebSockets (websocketsOr)
|
||||
import Network.Wai (responseLBS)
|
||||
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)
|
||||
|
||||
type Vertex = Session.App ()
|
||||
type Edges = Message.FromClient -> Vertex
|
||||
|
||||
newVertex :: String -> Edges -> Vertex
|
||||
newVertex name = do
|
||||
(Session.debug name >> catchPings >>=)
|
||||
where
|
||||
catchPings = Message.receive >>= pong
|
||||
pong Message.Ping = (Message.send Message.Pong >> catchPings)
|
||||
pong m = return m
|
||||
|
||||
enter :: Vertex
|
||||
enter = do
|
||||
Session.debug "Initial state"
|
||||
Session.get id >>= (Message.send . Message.Welcome)
|
||||
connected
|
||||
|
||||
onErrorGoto :: Vertex -> String -> Session.App ()
|
||||
onErrorGoto vertex message =
|
||||
(Message.send $ Message.Error message) >> vertex
|
||||
|
||||
connected :: Vertex
|
||||
connected = newVertex "Connected" edges
|
||||
where
|
||||
edges logIn@(Message.LogIn login) =
|
||||
Session.update (Server.logIn login)
|
||||
>>= maybe
|
||||
(Message.relay logIn Message.broadcast >> loggedIn)
|
||||
(onErrorGoto connected)
|
||||
edges _ = Session.debug "Invalid message" >> connected
|
||||
|
||||
loggedIn :: Vertex
|
||||
loggedIn = newVertex "Logged in" edges
|
||||
where
|
||||
edges logOut@Message.LogOut = do
|
||||
Message.relay logOut Message.broadcast
|
||||
Session.update Server.logOut
|
||||
>>= maybe
|
||||
connected
|
||||
(onErrorGoto loggedIn)
|
||||
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 ()
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
app <- Session.serve enter exit
|
||||
run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
||||
where
|
||||
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|
80
src/Message.hs
Normal file
80
src/Message.hs
Normal file
|
@ -0,0 +1,80 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Message (
|
||||
FromClient(..)
|
||||
, T(..)
|
||||
, broadcast
|
||||
, receive
|
||||
, relay
|
||||
, send
|
||||
) where
|
||||
|
||||
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 qualified Server (T(..))
|
||||
import qualified Session (App, connection, debug, get, player)
|
||||
import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
|
||||
import GHC.Generics (Generic)
|
||||
import Game ()
|
||||
|
||||
data FromClient =
|
||||
Answer {accept :: Bool}
|
||||
| Invitation {to :: Player.Name}
|
||||
| LogIn {name :: Player.Name}
|
||||
| LogOut
|
||||
| Game {move :: KoiKoi.Move}
|
||||
| Ping
|
||||
deriving (Generic)
|
||||
|
||||
instance ToJSON FromClient where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
instance FromJSON FromClient where
|
||||
parseJSON = genericParseJSON defaultOptions
|
||||
|
||||
data T =
|
||||
Relay {from :: Player.Name, message :: FromClient}
|
||||
| Welcome {room :: Server.T}
|
||||
| Pong
|
||||
| Error {error :: String}
|
||||
deriving (Generic)
|
||||
|
||||
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
|
||||
where
|
||||
encoded = encode $ obj
|
||||
playerLogin = unpack $ encode $ Player.login player
|
||||
|
||||
send :: T -> Session.App ()
|
||||
send obj =
|
||||
(obj `sendTo`) =<< Session.player
|
||||
|
||||
broadcast :: T -> Session.App ()
|
||||
broadcast obj =
|
||||
Session.get Server.bySessionId
|
||||
>>= mapM_ (obj `sendTo`)
|
||||
|
||||
relay :: FromClient -> (T -> Session.App ()) -> Session.App ()
|
||||
relay message f =
|
||||
Session.debug "Relaying"
|
||||
>> Session.player >>= (ifLoggedIn . Player.login)
|
||||
>> Session.debug "Relayed"
|
||||
where
|
||||
ifLoggedIn Player.Anonymous = return ()
|
||||
ifLoggedIn (Player.Login from) = f $ Relay {from, message}
|
||||
|
||||
receive :: Session.App FromClient
|
||||
receive = do
|
||||
received <- ((lift . receiveData) =<< Session.connection)
|
||||
Session.debug $ '>':(unpack received)
|
||||
case eitherDecode' received of
|
||||
Left errorMessage -> send (Message.Error errorMessage) >> receive
|
||||
Right clientMessage -> return clientMessage
|
70
src/Player.hs
Normal file
70
src/Player.hs
Normal file
|
@ -0,0 +1,70 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Player (
|
||||
Login(..)
|
||||
, Name(..)
|
||||
, Status(..)
|
||||
, T(..)
|
||||
, new
|
||||
) where
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), (.=), Value(..), genericToEncoding, object, pairs)
|
||||
import qualified JSON (defaultOptions, singleLCField)
|
||||
import qualified Data (RW(..))
|
||||
import Network.WebSockets (Connection)
|
||||
import GHC.Generics
|
||||
|
||||
newtype Name = Name Text deriving (Eq, Ord, Generic)
|
||||
data Login = Anonymous | Login Name
|
||||
|
||||
data Status =
|
||||
LoggedIn Bool
|
||||
| Answering Name
|
||||
| Waiting Name
|
||||
deriving (Generic)
|
||||
|
||||
data T = T {
|
||||
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 T where
|
||||
update f player@(T {status}) = player {status = f status}
|
||||
|
||||
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}
|
72
src/Server.hs
Normal file
72
src/Server.hs
Normal file
|
@ -0,0 +1,72 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Server (
|
||||
SessionId
|
||||
, T(..)
|
||||
, disconnect
|
||||
, join
|
||||
, logIn
|
||||
, logOut
|
||||
, new
|
||||
) where
|
||||
|
||||
import Data.Vector (fromList)
|
||||
import Data.Aeson (ToJSON(..), Value(Array))
|
||||
import Data.Map ((!), (!?), Map, adjust, delete, elems, empty, insert, lookupMax)
|
||||
import qualified Data (RW(..))
|
||||
import qualified Player (Login(..), Name(..), T(..))
|
||||
|
||||
newtype SessionId = SessionId Int deriving (Eq, Ord, Read, Show)
|
||||
type Players = Map SessionId Player.T
|
||||
type SessionIds = Map Player.Name SessionId
|
||||
data T = T {
|
||||
byName :: SessionIds
|
||||
, bySessionId :: Players
|
||||
}
|
||||
|
||||
instance Data.RW SessionIds T where
|
||||
update f server@(T {byName}) = server {byName = f byName}
|
||||
|
||||
instance Data.RW Players T where
|
||||
update f server@(T {bySessionId}) = server {bySessionId = f bySessionId}
|
||||
|
||||
loggedInPlayers :: T -> [Player.T]
|
||||
loggedInPlayers (T {byName, bySessionId}) =
|
||||
[(bySessionId ! sessionId) | sessionId <- elems byName]
|
||||
|
||||
instance ToJSON T where
|
||||
toJSON = Array . fromList . (toJSON <$>) . loggedInPlayers
|
||||
toEncoding = toEncoding . loggedInPlayers
|
||||
|
||||
new :: T
|
||||
new = T {
|
||||
byName = empty
|
||||
, bySessionId = empty
|
||||
}
|
||||
|
||||
join :: Player.T -> T -> IO (T, SessionId)
|
||||
join player server@(T {bySessionId}) =
|
||||
return (Data.update (insert sessionId player) server, sessionId)
|
||||
where
|
||||
sessionId = SessionId $ maybe 0 (\(SessionId n, _) -> n+1) $ lookupMax bySessionId
|
||||
|
||||
disconnect :: SessionId -> T -> Either String T
|
||||
disconnect sessionId server =
|
||||
Data.update (delete sessionId :: Players -> Players) <$> logOut sessionId server
|
||||
|
||||
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
|
||||
|
||||
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)
|
64
src/Session.hs
Normal file
64
src/Session.hs
Normal file
|
@ -0,0 +1,64 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module Session (
|
||||
App
|
||||
, T(..)
|
||||
, connection
|
||||
, debug
|
||||
, get
|
||||
, player
|
||||
, serve
|
||||
, update
|
||||
) where
|
||||
|
||||
import Data.Map ((!))
|
||||
import Control.Concurrent (MVar, newMVar, modifyMVar, putMVar, readMVar, takeMVar)
|
||||
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)
|
||||
|
||||
data T = T {
|
||||
server :: MVar Server.T
|
||||
, key :: Server.SessionId
|
||||
}
|
||||
|
||||
type App a = ReaderT T IO a
|
||||
|
||||
get :: (Server.T -> a) -> App a
|
||||
get f =
|
||||
asks server
|
||||
>>= lift . (f <$>) . readMVar
|
||||
|
||||
player :: App Player.T
|
||||
player = do
|
||||
sId <- asks key
|
||||
get ((! sId) . Server.bySessionId)
|
||||
|
||||
connection :: App Connection
|
||||
connection = Player.connection <$> player
|
||||
|
||||
debug :: String -> App ()
|
||||
debug message =
|
||||
show <$> asks Session.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
|
||||
|
||||
serve :: App () -> App () -> IO ServerApp
|
||||
serve onEnter onExit = do
|
||||
server <- newMVar Server.new
|
||||
return $ \pending -> do
|
||||
key <- acceptRequest pending
|
||||
>>= return . Player.new
|
||||
>>= modifyMVar server . Server.join
|
||||
finally
|
||||
(runReaderT onEnter $ T {server, key})
|
||||
(runReaderT onExit $ T {server, key})
|
||||
|
42
www/connect.js
Normal file
42
www/connect.js
Normal file
|
@ -0,0 +1,42 @@
|
|||
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 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);
|
||||
switch(o.tag) {
|
||||
case "Welcome":
|
||||
room.populate(o.room);
|
||||
break;
|
||||
case "Pong":
|
||||
setTimeout(ping, 10000);
|
||||
break;
|
||||
case "Relay":
|
||||
relayedMessage(o)
|
||||
break;
|
||||
default:
|
||||
debug.textContent = event.data;
|
||||
}
|
||||
});
|
||||
|
||||
function relayedMessage(o) {
|
||||
switch(o.message.tag) {
|
||||
case "LogIn":
|
||||
room.enter(o.from);
|
||||
login.onLogIn(o.from);
|
||||
break;
|
||||
case "LogOut":
|
||||
room.leave(o.from);
|
||||
login.onLogOut(o.from);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
function ping() {
|
||||
lib.send({tag: "Ping"});
|
||||
}
|
||||
});
|
29
www/index.html
Normal file
29
www/index.html
Normal file
|
@ -0,0 +1,29 @@
|
|||
<!DOCTYPE HTML>
|
||||
<html>
|
||||
<head>
|
||||
<title>KoiKoi</title>
|
||||
<script src="lib.js"></script>
|
||||
<script src="login.js"></script>
|
||||
<script src="room.js"></script>
|
||||
<script src="connect.js"></script>
|
||||
<link rel="stylesheet" href="skin.css" type="text/css"/>
|
||||
</head>
|
||||
<body>
|
||||
<p>Hanafuda</p>
|
||||
<form id="login">
|
||||
<p id="join">
|
||||
<label for="name">Name</label><input type="text" name="name"/>
|
||||
<input type="submit" name="join" value="Join"/>
|
||||
</p>
|
||||
<p id="leave">
|
||||
<input type="button" name="leave" value="Leave"/>
|
||||
</p>
|
||||
</form>
|
||||
<form id="room">
|
||||
<ul id="players">
|
||||
</ul>
|
||||
<input type="submit" name="invite" value="Invite to a game" disabled/>
|
||||
</form>
|
||||
<p id="debug"></p>
|
||||
</body>
|
||||
</html>
|
27
www/lib.js
Normal file
27
www/lib.js
Normal file
|
@ -0,0 +1,27 @@
|
|||
function Lib(ws) {
|
||||
return {
|
||||
clearElement: clearElement,
|
||||
insert: insert,
|
||||
send: send
|
||||
};
|
||||
|
||||
function clearElement(elem) {
|
||||
while(elem.firstChild) {
|
||||
elem.removeChild(elem.firstChild);
|
||||
}
|
||||
}
|
||||
|
||||
function insert(obj, t, min, max) {
|
||||
min = min || 0;
|
||||
max = max || t.length;
|
||||
if(max - min < 1) {
|
||||
return min;
|
||||
}
|
||||
var avg = Math.floor((max + min) / 2);
|
||||
return (obj < t[avg]) ? insert(obj, t, min, avg) : insert(obj, t, avg+1, max);
|
||||
}
|
||||
|
||||
function send(o) {
|
||||
ws.send(JSON.stringify(o));
|
||||
}
|
||||
}
|
30
www/login.js
Normal file
30
www/login.js
Normal file
|
@ -0,0 +1,30 @@
|
|||
function Login(domElem, lib) {
|
||||
var login = null;
|
||||
domElem.addEventListener('submit', function(e) {
|
||||
e.preventDefault();
|
||||
lib.send({tag: "LogIn", name: domElem.name.value})
|
||||
});
|
||||
domElem.leave.addEventListener('click', function(e) {
|
||||
e.preventDefault();
|
||||
lib.send({tag: "LogOut"})
|
||||
});
|
||||
|
||||
return {
|
||||
onLogIn: onLogIn,
|
||||
onLogOut: onLogOut
|
||||
};
|
||||
|
||||
function onLogIn(name) {
|
||||
if(name == domElem.name.value) {
|
||||
domElem.className = "on";
|
||||
login = name;
|
||||
}
|
||||
}
|
||||
|
||||
function onLogOut(name) {
|
||||
if(name == login) {
|
||||
login = null;
|
||||
domElem.className = "";
|
||||
}
|
||||
}
|
||||
}
|
40
www/room.js
Normal file
40
www/room.js
Normal file
|
@ -0,0 +1,40 @@
|
|||
function Room(domElem, lib) {
|
||||
var players = {};
|
||||
var logins = [];
|
||||
|
||||
return {
|
||||
populate: populate,
|
||||
enter: enter,
|
||||
leave: leave
|
||||
};
|
||||
|
||||
function Player(name) {
|
||||
var player = {
|
||||
dom: document.createElement('li'),
|
||||
position: null
|
||||
};
|
||||
player.dom.textContent = name;
|
||||
return player;
|
||||
}
|
||||
|
||||
function populate(playersList) {
|
||||
lib.clearElement(domElem);
|
||||
for(var i = 0; i < playersList.length; i++) {
|
||||
enter(playersList[i].login || "anon");
|
||||
}
|
||||
}
|
||||
|
||||
function enter(name) {
|
||||
var player = Player(name);
|
||||
players[name] = player;
|
||||
player.position = lib.insert(name, logins);
|
||||
beforePlayer = logins[player.position];
|
||||
domElem.insertBefore(player.dom, beforePlayer && players[beforePlayer].dom);
|
||||
logins.splice(player.position, 0, name);
|
||||
}
|
||||
|
||||
function leave(name) {
|
||||
domElem.removeChild(players[name].dom);
|
||||
logins.splice(players[name].position, 1);
|
||||
}
|
||||
}
|
19
www/skin.css
Normal file
19
www/skin.css
Normal file
|
@ -0,0 +1,19 @@
|
|||
#leave {
|
||||
display: none;
|
||||
}
|
||||
|
||||
#login.on #join {
|
||||
display: none;
|
||||
}
|
||||
|
||||
#login.on #leave {
|
||||
display: inline;
|
||||
}
|
||||
|
||||
#players {
|
||||
min-height: 4em;
|
||||
border: 1px solid #ccc;
|
||||
list-style: none;
|
||||
padding-left: 0;
|
||||
cursor: pointer;
|
||||
}
|
Loading…
Reference in a new issue