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

Basic client dialogs to login and start a new game

This commit is contained in:
Sasha 2018-05-11 12:31:53 +02:00
parent a405c3d8ea
commit 2cf5d48419
22 changed files with 709 additions and 389 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ChangeLog.md
View File

@ -1,5 +1,9 @@
# Revision history for hanafudapi
## 0.1.1.0 -- 2018-05-11
* Basic client dialogs to login and start a new game
## 0.1.0.0 -- 2018-03-17
* First version. Released on an unsuspecting world.

7
hanafudapi.cabal
View File

@ -2,8 +2,8 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: hanafudapi
version: 0.1.0.0
synopsis: An API for the Haskell hanafuda library
version: 0.1.1.0
synopsis: A webapp for the Haskell hanafuda library
-- description:
homepage: https://framagit.org/hanafuda
license: BSD3
@ -21,7 +21,8 @@ source-repository head
executable hanafudapi
main-is: Main.hs
other-modules: Automaton
other-modules: App
, Automaton
, Config
, Message
, Game

64
src/App.hs Normal file
View File

@ -0,0 +1,64 @@
{-# LANGUAGE NamedFieldPuns #-}
module App (
T
, Context(..)
, connection
, debug
, get
, current
, server
, try
, update
, update_
) where
import Data.Map ((!))
import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Network.WebSockets (Connection)
import qualified Player (Key)
import qualified Session (T(..))
import qualified Server (T(..))
data Context = Context {
mServer :: MVar Server.T
, key :: Player.Key
}
type T a = ReaderT Context IO a
server :: T Server.T
server = asks mServer >>= lift . readMVar
get :: Player.Key -> T Session.T
get key =
(! key) . Server.sessions <$> server
current :: T Session.T
current = do
asks key >>= get
connection :: T Connection
connection = Session.connection <$> current
debug :: String -> T ()
debug message =
show <$> asks key
>>= 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
Context {mServer} <- ask
lift $ modifyMVar mServer (return . f)
update_ :: (Server.T -> Server.T) -> T ()
update_ f = update $ (\x -> (x, ())) . f

94
src/Automaton.hs
View File

@ -3,66 +3,78 @@ module Automaton (
start
) where
import Control.Monad.Reader (asks)
import qualified Player (Session(..), Status(..))
import qualified Server (logIn, logOut, setStatus)
import qualified Session (App, T(..), current, debug, get, server, try, update)
import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo)
import Control.Monad.Reader (asks, lift)
import qualified Game (export, new)
import qualified Session (Status(..), T(..))
import qualified Server (get, logIn, logOut, setStatus, register)
import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo, update)
type Vertex = Player.Status
type Vertex = Session.Status
edges :: Vertex -> Message.FromClient -> Session.App Vertex
edges :: Vertex -> Message.FromClient -> App.T Vertex
edges (Player.LoggedIn False) logIn@(Message.LogIn login) =
asks Session.key >>= Session.try . (Server.logIn login)
edges (Session.LoggedIn False) logIn@(Message.LogIn login) =
asks App.key >>= App.try . (Server.logIn login)
>>= maybe
(Message.relay logIn Message.broadcast >> return (Player.LoggedIn True))
(withError $ Player.LoggedIn False)
(Message.relay logIn Message.broadcast >> return (Session.LoggedIn True))
(withError $ Session.LoggedIn False)
edges (Player.LoggedIn True) logOut@Message.LogOut = do
edges (Session.LoggedIn True) logOut@Message.LogOut = do
Message.relay logOut Message.broadcast
asks Session.key >>= Session.update . Server.logOut
return (Player.LoggedIn False)
asks App.key >>= App.update_ . Server.logOut
return (Session.LoggedIn False)
edges (Player.LoggedIn True) 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.Answering key) to)
(Message.relay invitation $ Message.sendTo (to, session))
return (Player.Waiting to)
_ -> Player.LoggedIn True `withError` "They just left"
edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
session <- App.get to
case Session.status session of
Session.LoggedIn True -> do
key <- asks App.key
App.update_ (Server.setStatus (Session.Answering key) to)
Message.broadcast $ Message.update {Message.paired = [key, to]}
(Message.relay invitation $ Message.sendTo [(to, session)])
return (Session.Waiting to)
_ -> Session.LoggedIn True `withError` "They just left"
edges (Player.Answering to) message@(Message.Answer {Message.accept}) = do
session <- Session.get to
key <- asks Session.key
case Player.status session of
Player.Waiting for | for == key -> do
Message.relay message $ Message.sendTo (to, session)
if accept
then Session.debug "Yeah ! Let's start a game" >> return (Player.LoggedIn True)
else Session.debug "Oh, they said no" >> return (Player.LoggedIn True)
_ -> (Player.LoggedIn True) `withError` "They're not waiting for your answer"
edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
session <- App.get to
key <- asks App.key
case Session.status session of
Session.Waiting for | for == key -> do
Message.relay message $ Message.sendTo [(to, session)]
newStatus <-
if accept
then do
gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
game <- Server.get gameKey <$> App.server
current <- App.current
Message.sendTo [(to, session), (key, current)] $ Message.NewGame $ Game.export game
return $ Session.Playing gameKey
else do
Message.broadcast $ Message.update {Message.alone = [key, to]}
return $ Session.LoggedIn True
App.update_ $ Server.setStatus newStatus for
return newStatus
_ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
edges state _ =
state `withError` ("Invalid message in state " ++ show state)
withError :: Vertex -> String -> Session.App Vertex
withError :: Vertex -> String -> App.T Vertex
withError vertex message =
(Message.send $ Message.Error message) >> return vertex
run :: Session.App ()
run :: App.T ()
run = do
message <- Message.get
status <- Player.status <$> Session.current
status <- Session.status <$> App.current
newStatus <- edges status message
Server.setStatus newStatus <$> asks Session.key >>= Session.update
Session.debug $ show newStatus
asks App.key >>= App.update_ . Server.setStatus newStatus
App.debug $ show newStatus
run
start :: Session.App ()
start :: App.T ()
start = do
Session.debug "Initial state"
Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send
App.debug "Initial state"
Message.Welcome <$> App.server <*> asks App.key >>= Message.send
run

27
src/Data.hs
View File

@ -1,9 +1,30 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
module Data (
RW(..)
Key(..)
, RW(..)
) where
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSONKey(..), genericToEncoding)
import Data.Aeson.Types (toJSONKeyText)
import Data.Text (pack)
import GHC.Generics
import qualified JSON (defaultOptions)
class RW a b where
update :: (a -> a) -> b -> b
get :: b -> a
set :: a -> b -> b
set = update . const
update :: (a -> a) -> b -> b
update f v =
set (f (get v)) v
newtype Key a = Key Int deriving (Eq, Ord, Enum, Read, Show, Generic)
instance FromJSON (Key a)
instance ToJSON (Key a) where
toEncoding = genericToEncoding JSON.defaultOptions
instance ToJSONKey (Key a) where
toJSONKey = toJSONKeyText (pack . \(Key n) -> show n)

61
src/Game.hs
View File

@ -1,19 +1,62 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
module Game where
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Game (
Key
, State(..)
, T(..)
, export
, new
) where
import Hanafuda (Card(..))
import Hanafuda.KoiKoi (Move(..))
import Data.Map (Map, (!), fromList, mapKeys)
import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding)
import qualified JSON (singleLCField)
import qualified Data (Key)
import qualified Player (Key)
import qualified Hanafuda (Card(..), cardsOfPack)
import qualified Hanafuda.Player (Player(..), Seat(..))
import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), new)
import GHC.Generics
deriving instance Generic Card
deriving instance Generic Move
deriving instance Generic Hanafuda.Card
deriving instance Generic Hanafuda.KoiKoi.Move
instance FromJSON Card
instance ToJSON Card
instance FromJSON Hanafuda.Card
instance ToJSON Hanafuda.Card
instance FromJSON Move
instance ToJSON Move where
instance FromJSON Hanafuda.KoiKoi.Move
instance ToJSON Hanafuda.KoiKoi.Move where
toEncoding = genericToEncoding JSON.singleLCField
data T = T {
seats :: Map Hanafuda.Player.Seat Player.Key
, state :: Hanafuda.KoiKoi.On
}
type Key = Data.Key T
data State = State {
river :: [Hanafuda.Card]
, yakus :: Map Player.Key [Hanafuda.Card]
} deriving (Generic)
instance ToJSON State where
toEncoding = genericToEncoding JSON.singleLCField
new :: Player.Key -> Player.Key -> IO T
new p1 p2 = do
state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
return $ T {
seats = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
, state
}
export :: T -> State
export (T {seats, state}) = State {
river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
, yakus = fmap extractYakus players
}
where
extractYakus = Hanafuda.cardsOfPack . Hanafuda.Player.meld
players = mapKeys (seats !) $ Hanafuda.KoiKoi.players state

23
src/Main.hs
View File

@ -11,28 +11,27 @@ import Control.Monad.Reader (ReaderT(..), asks)
import Control.Concurrent (newMVar, modifyMVar)
import Control.Exception (finally)
import qualified Config (listenPort)
import qualified Player (openSession)
import qualified Server (disconnect, join, new)
import qualified Session (App, T(..), update)
import qualified Session (open)
import qualified Server (disconnect, new, register)
import qualified App (Context(..), T, update_)
import qualified Message (FromClient(..), broadcast, relay)
import qualified Automaton (start)
exit :: Session.App ()
exit :: App.T ()
exit = do
asks Session.key >>= Session.update . Server.disconnect
asks App.key >>= App.update_ . Server.disconnect
Message.relay Message.LogOut Message.broadcast
serverApp :: Session.App () -> Session.App () -> IO ServerApp
serverApp :: App.T () -> App.T () -> IO ServerApp
serverApp onEnter onExit = do
mServer <- newMVar Server.new
return $ \pending -> do
key <- acceptRequest pending
>>= return . Player.openSession
>>= modifyMVar mServer . Server.join
let session = Session.T {Session.mServer, Session.key}
session <- Session.open <$> acceptRequest pending
key <- modifyMVar mServer (return . Server.register session)
let app = App.Context {App.mServer, App.key}
finally
(runReaderT onEnter session)
(runReaderT onExit session)
(runReaderT onEnter app)
(runReaderT onExit app)
main :: IO ()
main = do

57
src/Message.hs
View File

@ -9,25 +9,29 @@ module Message (
, relay
, send
, sendTo
, update
) where
import Data.List (intercalate)
import Data.Foldable (forM_)
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 Data.Text (Text)
import Control.Monad.Reader (asks, lift)
import qualified Player (Key, Name, Session(..))
import qualified Player (Key)
import qualified Game (State)
import qualified Session (T(..))
import qualified Server (T(..))
import qualified Session (App, T(..), connection, current, debug, server)
import qualified App (Context(..), 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.Key}
| LogIn {name :: Player.Name}
| LogIn {name :: Text}
| LogOut
| Game {move :: KoiKoi.Move}
| Ping
@ -41,6 +45,8 @@ instance FromJSON FromClient where
data T =
Relay {from :: Player.Key, message :: FromClient}
| Welcome {room :: Server.T, key :: Player.Key}
| Update {alone :: [Player.Key], paired :: [Player.Key]}
| NewGame Game.State
| Pong
| Error {error :: String}
deriving (Generic)
@ -48,40 +54,45 @@ data T =
instance ToJSON T where
toEncoding = genericToEncoding defaultOptions
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
sendTo :: [(Player.Key, Session.T)] -> T -> App.T ()
sendTo sessions obj = do
App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
lift $ forM_ connections $ flip sendTextData encoded
where
encoded = encode $ obj
(recipients, connections) = unzip [
(show key, Session.connection session) | (key, session) <- sessions
]
send :: T -> Session.App ()
send :: T -> App.T ()
send obj = do
key <- asks Session.key
session <- Session.current
sendTo (key, session) obj
key <- asks App.key
session <- App.current
sendTo [(key, session)] obj
broadcast :: T -> Session.App ()
broadcast :: T -> App.T ()
broadcast obj =
(toList . Server.sessions) <$> Session.server
>>= mapM_ (flip sendTo obj)
App.server >>= flip sendTo obj . toList . Server.sessions
relay :: FromClient -> (T -> Session.App ()) -> Session.App ()
relay :: FromClient -> (T -> App.T ()) -> App.T ()
relay message f = do
Session.debug "Relaying"
(\from -> f $ Relay {from, message}) =<< asks Session.key
App.debug "Relaying"
(\from -> f $ Relay {from, message}) =<< asks App.key
receive :: Session.App FromClient
receive :: App.T FromClient
receive = do
received <- ((lift . receiveData) =<< Session.connection)
Session.debug $ '>':(unpack received)
received <- ((lift . receiveData) =<< App.connection)
App.debug $ '>':(unpack received)
case eitherDecode' received of
Left errorMessage -> send (Message.Error errorMessage) >> receive
Right clientMessage -> return clientMessage
get :: Session.App Message.FromClient
get :: App.T Message.FromClient
get =
receive >>= pong
where
pong Ping = send Pong >> get
pong m = return m
update :: T
update = Update {alone = [], paired = []}

44
src/Player.hs
View File

@ -1,25 +1,22 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Player (
Key(..)
, Name
, Session(..)
, Status(..)
, openSession
Key
, T(..)
) where
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 Data.Text (Text)
import qualified Data (Key)
import GHC.Generics
newtype Key = Key Int deriving (Eq, Ord, Read, Show, Generic)
newtype Name = Name Text deriving (Eq, Ord, Generic)
data T = T {
name :: Text
} deriving (Eq, Ord, Generic)
type Key = Data.Key T
{-
instance FromJSON Key
instance ToJSON Key where
toEncoding = genericToEncoding JSON.defaultOptions
@ -30,23 +27,4 @@ instance ToJSONKey Key where
instance FromJSON Name
instance ToJSON Name where
toEncoding = genericToEncoding JSON.defaultOptions
data Status =
LoggedIn Bool
| Answering Key
| Waiting Key
deriving (Show, Generic)
data Session = Session {
connection :: Connection
, status :: Status
}
instance Data.RW Status Session where
update f session@(Session {status}) = session {status = f status}
openSession :: Connection -> Session
openSession connection = Session {
connection
, status = LoggedIn False
}
-}

105
src/Server.hs
View File

@ -1,78 +1,115 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Server (
T(..)
, disconnect
, join
, get
, logIn
, logOut
, new
, register
, setStatus
) where
import Data.Map ((!?), Map, adjust, delete, insert, lookupMax)
import Data.Aeson (ToJSON(..), (.=), object, pairs)
import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
import qualified Data.Map as Map (empty)
import Data.Aeson (ToJSON(..))
import Data.Monoid ((<>))
import Data.Set (Set, member)
import qualified Data.Set as Set (delete, empty, insert)
import Data.Text (Text)
import qualified Data (RW(..))
import qualified Player (Key(..), Name, Session(..), Status(..))
import qualified Game (Key, T(..))
import qualified Player (Key, T(..))
import qualified Session (Status(..), T(..))
type Keys = Map Player.Name Player.Key
type Names = Map Player.Key Player.Name
type Sessions = Map Player.Key Player.Session
type Names = Set Text
type Players = Map Player.Key Player.T
type Sessions = Map Player.Key Session.T
type Games = Map Game.Key Game.T
data T = T {
keys :: Keys
, names :: Names
names :: Names
, players :: Players
, sessions :: Sessions
, games :: Games
}
instance Data.RW Keys T where
update f server@(T {keys}) = server {keys = f keys}
instance Data.RW Names T where
update f server@(T {names}) = server {names = f names}
get = names
set names server = server {names}
instance Data.RW Players T where
get = players
set players server = server {players}
instance Data.RW Sessions T where
update f server@(T {sessions}) = server {sessions = f sessions}
get = sessions
set sessions server = server {sessions}
instance Data.RW Games T where
get = games
set games server = server {games}
newtype Player = Player (Text, Bool)
instance ToJSON Player where
toJSON (Player (name, alone)) = object ["name" .= name, "alone" .= alone]
toEncoding (Player (name, alone)) = pairs ("name" .= name <> "alone" .= alone)
export :: Sessions -> Player.Key -> Player.T -> Player
export sessions key player = Player (Player.name player, alone)
where
alone =
case Session.status (sessions ! key) of
Session.LoggedIn True -> True
_ -> False
instance ToJSON T where
toJSON = toJSON . names
toEncoding = toEncoding . names
toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players
new :: T
new = T {
keys = Map.empty
, names = Map.empty
names = Set.empty
, players = Map.empty
, sessions = Map.empty
, games = Map.empty
}
join :: Player.Session -> T -> IO (T, Player.Key)
join session server@(T {sessions}) =
return (Data.update (insert key session) server, key)
where
key = Player.Key $ maybe 0 (\(Player.Key n, _) -> n+1) $ lookupMax sessions
register :: forall a b. (Enum a, Ord a, Data.RW (Map a b) T) => b -> T -> (T, a)
register x server =
let key = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
(Data.update (insert key x) server, key)
get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
get key server = (Data.get server :: Map a b) ! key
disconnect :: Player.Key -> T -> T
disconnect key =
Data.update (delete key :: Sessions -> Sessions) . logOut key
logIn :: Player.Name -> Player.Key -> T -> Either String T
logIn :: Text -> 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)
Data.update (Set.insert name) .
Data.update (insert key $ Player.T {Player.name}) .
setStatus (Session.LoggedIn True) key <$>
if name `member` names server
then Left "This name is already registered"
else Right 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)
(\player ->
Data.update (delete key :: Players -> Players) $
setStatus (Session.LoggedIn False) key $
Data.update (Set.delete $ Player.name player :: Names -> Names) server)
(players server !? key)
setStatus :: Player.Status -> Player.Key -> T -> T
setStatus :: Session.Status -> Player.Key -> T -> T
setStatus status key =
Data.update (adjust (Data.set status) key :: Sessions -> Sessions)

78
src/Session.hs
View File

@ -1,59 +1,41 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
module Session (
App
Status(..)
, T(..)
, connection
, debug
, get
, current
, server
, try
, update
, open
) where
import Data.Map ((!))
import Control.Concurrent (MVar, modifyMVar_, putMVar, readMVar, takeMVar)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Network.WebSockets (Connection)
import qualified Player (Key, Session(..))
import qualified Server (T(..))
import Data.Aeson (ToJSON(..), genericToEncoding)
import GHC.Generics (Generic)
import qualified JSON (singleLCField)
import qualified Data (RW(..))
import qualified Player (Key)
import qualified Game (Key)
data Status =
LoggedIn Bool
| Answering Player.Key
| Waiting Player.Key
| Playing Game.Key
deriving (Show, Generic)
instance ToJSON Status where
toEncoding = genericToEncoding JSON.singleLCField
data T = T {
mServer :: MVar Server.T
, key :: Player.Key
connection :: Connection
, status :: Status
}
type App a = ReaderT T IO a
instance Data.RW Status T where
get = status
set status session = session {status}
server :: App Server.T
server = asks mServer >>= lift . readMVar
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 <$> current
debug :: String -> App ()
debug message =
show <$> asks key
>>= lift . putStrLn . (++ ' ':message)
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
{- Not using the previous to minimize the duration mServer gets locked -}
update :: (Server.T -> Server.T) -> App ()
update f = do
T {mServer} <- ask
lift $ modifyMVar_ mServer (return . f)
open :: Connection -> T
open connection = T {
connection
, status = LoggedIn False
}

56
www/connect.js
View File

@ -1,56 +0,0 @@
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('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);
switch(o.tag) {
case "Welcome":
sessionKey = o.key;
room.populate(o.room, sessionKey);
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, o.message.name);
if(o.from == sessionKey) {
login.on(o.from);
}
break;
case "LogOut":
room.leave(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});
}
}
function ping() {
lib.send({tag: "Ping"});
}
});

11
www/dom.js Normal file
View File

@ -0,0 +1,11 @@
function Dom() {
return {
clear: clear
}
function clear(elem) {
while(elem.firstChild) {
elem.removeChild(elem.firstChild);
}
}
}

45
www/index.html
View File

@ -2,28 +2,39 @@
<html>
<head>
<title>KoiKoi</title>
<script src="lib.js"></script>
<script src="dom.js"></script>
<script src="sort.js"></script>
<script src="session.js"></script>
<script src="login.js"></script>
<script src="room.js"></script>
<script src="connect.js"></script>
<script src="screen.js"></script>
<script src="messaging.js"></script>
<script src="main.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" class="off">
<ul class="players">
</ul>
<input type="submit" name="invite" value="Invite to a game" disabled/>
</form>
<div id="reception" class="on">
<h1>Hanafuda</h1>
<form id="login">
<input type="submit" name="submitButton" hidden disabled/>
<p id="join" class="on">
<label for="you">Pick a name you like</label><input type="text" name="you"/>
<input type="submit" name="join" value="Join" disabled/>
</p>
<p id="invite">
<label for="them">Start a game with</label><input type="text" name="them"/>
<input type="submit" name="invite" value="Invite" disabled/>
</p>
<ul class="players"></ul>
<p id="leave">
<input type="button" name="leave" value="Leave"/>
</p>
</form>
</div>
<div id="game">
<ul id="river"></ul>
<ul id="hand"></ul>
</div>
<p id="debug"></p>
</body>
</html>

133
www/login.js
View File

@ -1,23 +1,132 @@
function Login(domElem, lib) {
domElem.addEventListener('submit', function(e) {
function Login(modules) {
var root = document.getElementById('login');
var players = root.getElementsByClassName('players')[0];
var join = document.getElementById("join");
var invite = document.getElementById("invite");
var submit = root.submitButton;
var them = null;
root.addEventListener('submit', function(e) {
e.preventDefault();
lib.send({tag: "LogIn", name: domElem.name.value})
if(modules.session.loggedIn()) {
modules.messaging.send({tag: "Invitation", to: them});
} else {
modules.messaging.send({tag: "LogIn", name: root.you.value});
}
});
domElem.leave.addEventListener('click', function(e) {
root.leave.addEventListener('click', function(e) {
e.preventDefault();
lib.send({tag: "LogOut"})
});
return {
on: on,
off: off
};
root.you.addEventListener("input", function() {refreshPlayers(false);});
root.them.addEventListener("input", function() {refreshPlayers(true);});
function on(name) {
domElem.className = "on";
modules.messaging.addEventListener(["Welcome"], function() {
refreshPlayers(modules.session.loggedIn());
});
modules.messaging.addEventListener(["Update"], function(o) {
refreshPlayers(modules.session.loggedIn());
});
modules.messaging.addEventListener(["Relay", "LogIn"], function() {
playersChanged();
});
modules.messaging.addEventListener(["Relay", "LogOut"], function() {
playersChanged();
});
modules.messaging.addEventListener(["Relay", "Invitation"], function(o) {
var name = modules.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");
if(accept) {
modules.screen.select("game");
}
}
modules.messaging.send({tag: "Answer", accept: accept});
});
modules.messaging.addEventListener(["Relay", "Answer"], function(o) {
if(o.message.accept) {
modules.screen.select("game");
}
});
return {};
function playersChanged() {
var loggedIn = modules.session.loggedIn();
setMode(loggedIn);
refreshPlayers(loggedIn);
}
function off() {
domElem.className = "";
function refreshPlayers(loggedIn) {
modules.dom.clear(players);
if(loggedIn) {
refreshThem();
} else {
refreshYou();
}
}
function refreshYou() {
var nameTaken = false;
var name = root.you.value;
modules.room.filter(name).forEach(function(player) {
players.appendChild(player.dom);
nameTaken = nameTaken || name == player.name;
});
formDisable("join", name.length < 1 || nameTaken);
}
function refreshThem() {
them = null;
var name = root.them.value;
var filtered = modules.room.filter(name);
filtered.forEach(function(player) {
players.appendChild(player.dom);
});
var exact = filtered.find(exactMatch(name));
players.classList.remove("alone", "notFound");
if(exact != undefined) {
them = exact.key;
} else if(filtered.length == 1) {
them = filtered[0].key;
} else if(filtered.length == 0) {
players.classList.add(name.length > 0 ? "notFound" : "alone");
}
formDisable("invite", them == undefined);
}
function formDisable(name, disabled) {
[submit, root[name]].forEach(function(button) {
button.disabled = disabled;
});
}
function exactMatch(name) {
return function(player) {
return player.name === name;
};
}
function setMode(loggedIn) {
root.join.disabled = loggedIn;
root.invite.disabled = !loggedIn;
if(loggedIn) {
join.className = "";
invite.className = "on";
root.them.focus();
} else {
join.className = "on";
invite.className = "";
root.you.focus();
}
}
}

11
www/main.js Normal file
View File

@ -0,0 +1,11 @@
window.addEventListener('load', function() {
var dom = Dom();
var sort = Sort();
var screen = Screen();
var messaging = Messaging();
var session = Session({messaging: messaging});
var room = Room({dom: dom, messaging: messaging, session: session, sort: sort});
var login = Login({dom: dom, messaging: messaging, room: room, screen: screen, session: session});
messaging.start();
});

62
www/messaging.js Normal file
View File

@ -0,0 +1,62 @@
function Messaging(screen) {
var ws = new WebSocket('ws://' + window.location.hostname + '/play/');
var keepAlivePeriod = 20000;
var routes = {callbacks: [], children: {}};
return {
addEventListener: addEventListener,
send: send,
start: start
}
function get(obj, path, write) {
write = write || false;
if(path.length < 1) {
return obj;
} else {
if(obj.children[path[0]] == undefined && write) {
obj.children[path[0]] = {callbacks: [], children: {}};
}
if(obj.children[path[0]] != undefined) {
return get(obj.children[path[0]], path.slice(1), write);
} else {
return null;
}
}
}
function addEventListener(path, callback) {
var route = get(routes, path, true);
route.callbacks.push(callback);
}
function messageListener(event) {
var o = JSON.parse(event.data);
var path = [];
var tmp = o;
while(tmp != undefined && tmp.tag != undefined) {
path.push(tmp.tag);
tmp = tmp.message;
}
var route = get(routes, path);
if(route != undefined && route.callbacks != undefined) {
route.callbacks.forEach(function(f) {f(o);});
} else {
debug.textContent = event.data;
}
};
function start() {
ping();
addEventListener(["Pong"], ping);
ws.addEventListener('message', messageListener);
}
function send(o) {
ws.send(JSON.stringify(o));
}
function ping() {
setTimeout(function() {send({tag: "Ping"});}, keepAlivePeriod);
}
}

124
www/room.js
View File

@ -1,4 +1,14 @@
function Room(domElem, lib) {
function Room(modules) {
function Player(key, name, alone) {
this.key = key;
this.name = name;
this.alone = alone;
this.dom = document.createElement('li');
this.dom.textContent = name;
this.position = null;
}
var players = {};
var sortedKeys = [];
var session = {
@ -6,67 +16,61 @@ function Room(domElem, lib) {
loggedIn: false,
selected: null
};
var playersList = domElem.getElementsByClassName('players')[0];
domElem.addEventListener('submit', function(e) {
e.preventDefault();
lib.send({tag: "Invitation", to: session.selected})
modules.messaging.addEventListener(["Welcome"], function(o) {
for(var key in o.room) {
enter(parseInt(key), o.room[key]);
}
});
var compareKeysByLogin = lib.funMap(function(key) {return players[key].name;}, lib.defaultCompare);
modules.messaging.addEventListener(["Update"], function(o) {
o.alone.forEach(function(key) {players[key].alone = true;});
o.paired.forEach(function(key) {players[key].alone = false;});
});
modules.messaging.addEventListener(["Relay", "LogIn"], function(o) {
enter(o.from, o.message);
});
modules.messaging.addEventListener(["Relay", "LogOut"], function(o) {
leave(o.from);
});
var compareKeysByLogin = modules.sort.map(function(key) {return players[key].name;}, modules.sort.defaultCompare);
return {
populate: populate,
filter: filter,
enter: enter,
leave: leave,
name: 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);
}
});
function filter(name) {
if(modules.session.loggedIn()) {
var keep = function(player) {
return player.name.match(name) && !modules.session.is(player.key) && player.alone;
};
} else {
on();
player.dom.title = "Hey ! That's you !";
var keep = function(player) {return player.name.match(name);};
}
return player;
return sortedKeys.reduce(function(accumulator, key) {
var player = players[key];
return keep(player) ? accumulator.concat(player) : accumulator;
}, []);
}
function populate(playersHash, sessionKey) {
session.key = sessionKey;
lib.clearElement(playersList);
for(var key in playersHash) {
enter(parseInt(key), playersHash[key] || "anon");
}
}
function enter(key, name) {
var player = Player(key, name);
function enter(key, obj) {
var name = obj.name || "anon";
var alone = obj.alone != undefined ? obj.alone : true;
var player = new Player(key, name, alone);
players[key] = player;
player.position = lib.insert(key, sortedKeys, compareKeysByLogin);
beforePlayer = players[sortedKeys[player.position]];
playersList.insertBefore(player.dom, beforePlayer && beforePlayer.dom);
player.position = modules.sort.insert(key, sortedKeys, compareKeysByLogin);
sortedKeys.splice(player.position, 0, key);
}
function leave(key) {
var player = players[key];
if(key === session.key) {
off();
} else if(key === session.selected) {
reset();
}
if(player != undefined) {
playersList.removeChild(player.dom);
sortedKeys.splice(player.position, 1);
delete players[key];
}
@ -76,38 +80,4 @@ function Room(domElem, lib) {
player = players[key];
return player && player.name;
}
function on() {
domElem.className = "";
session.loggedIn = true;
}
function off() {
domElem.className = "off";
session.loggedIn = false;
reset();
}
function select(key) {
if(key === session.selected) {
unselect(key);
} else {
reset();
players[key].dom.className = "selected";
session.selected = key;
domElem.invite.disabled = false;
}
}
function reset() {
if(session.selected) {
unselect(session.selected);
}
}
function unselect(key) {
players[key].dom.className = "";
session.selected = null;
domElem.invite.disabled = true;
}
}

13
www/screen.js Normal file
View File

@ -0,0 +1,13 @@
function Screen() {
var current = document.querySelector("body > div.on");
return {
select: select
};
function select(name) {
current.className = "";
current = document.getElementById(name);
current.className = "on";
}
}

27
www/session.js Normal file
View File

@ -0,0 +1,27 @@
function Session(modules) {
var key = null;
var name = null;
modules.messaging.addEventListener(["Welcome"], function(o) {
key = o.key;
});
modules.messaging.addEventListener(["Relay", "LogIn"], function(o) {
if(is(o.from)) {
name = o.message.name;
}
});
return {
is: is,
loggedIn: loggedIn
};
function is(sessionKey) {
return key == sessionKey;
}
function loggedIn() {
return name != undefined;
}
}

35
www/skin.css
View File

@ -1,3 +1,19 @@
body > div {
display: none;
}
body > div.on {
display: block;
}
#join, #invite {
display: none;
}
#join.on, #invite.on {
display: block;
}
#leave {
display: none;
}
@ -10,19 +26,24 @@
display: inline;
}
#room .players {
#login .players {
min-height: 4em;
border: 1px solid #ccc;
list-style: none;
padding-left: 0;
cursor: pointer;
}
#room.off .players li {
color: #777;
.players:empty::before {
display: block;
text-align: center;
margin: 1em;
color: #555;
}
#room .players .selected {
background: #92c8f6;
color: #fff;
.players.alone::before {
content: "No one to play with yet ! Wait a little";
}
.players.notFound::before {
content: "No one by that name is awaiting an opponent";
}

17
www/lib.js → www/sort.js
View File

@ -1,18 +1,10 @@
function Lib(ws) {
function Sort() {
return {
clearElement: clearElement,
defaultCompare: defaultCompare,
funMap: funMap,
map: map,
insert: insert,
send: send
};
function clearElement(elem) {
while(elem.firstChild) {
elem.removeChild(elem.firstChild);
}
}
function insert(obj, t, compare, min, max) {
min = min == undefined ? 0 : min;
max = max == undefined ? t.length : max;
@ -38,14 +30,11 @@ function Lib(ws) {
}
}
function funMap(projector, f) {
function map(projector, f) {
return function() {
var args = Array.prototype.map.call(arguments, projector);
return f.apply(null, args);
}
}
function send(o) {
ws.send(JSON.stringify(o));
}
}