diff --git a/ChangeLog.md b/ChangeLog.md index 055f770..139a935 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/hanafudapi.cabal b/hanafudapi.cabal index 992cdf9..73c8510 100644 --- a/hanafudapi.cabal +++ b/hanafudapi.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs new file mode 100644 index 0000000..9465550 --- /dev/null +++ b/src/App.hs @@ -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 diff --git a/src/Automaton.hs b/src/Automaton.hs index c060d91..7f4f8ed 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -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 diff --git a/src/Data.hs b/src/Data.hs index a7bec41..c97b446 100644 --- a/src/Data.hs +++ b/src/Data.hs @@ -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) diff --git a/src/Game.hs b/src/Game.hs index 84fc916..694e402 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 8794bc5..af3515f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Message.hs b/src/Message.hs index ebf1ac6..c84c6fd 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -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 = []} diff --git a/src/Player.hs b/src/Player.hs index eae2791..e5a207e 100644 --- a/src/Player.hs +++ b/src/Player.hs @@ -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 - } +-} diff --git a/src/Server.hs b/src/Server.hs index cf0005f..141b445 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -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) diff --git a/src/Session.hs b/src/Session.hs index 53ffe83..2195db9 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -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 + } diff --git a/www/connect.js b/www/connect.js deleted file mode 100644 index 1cca538..0000000 --- a/www/connect.js +++ /dev/null @@ -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"}); - } -}); diff --git a/www/dom.js b/www/dom.js new file mode 100644 index 0000000..228a4df --- /dev/null +++ b/www/dom.js @@ -0,0 +1,11 @@ +function Dom() { + return { + clear: clear + } + + function clear(elem) { + while(elem.firstChild) { + elem.removeChild(elem.firstChild); + } + } +} diff --git a/www/index.html b/www/index.html index bf1a99e..ced10e4 100644 --- a/www/index.html +++ b/www/index.html @@ -2,28 +2,39 @@ KoiKoi - + + + - + + + -

Hanafuda

-
-

- - -

-

- -

-
-
- - -
+
+

Hanafuda

+
+ +

+ + +

+

+ + +

+ +

+ +

+
+
+
+ + +

diff --git a/www/login.js b/www/login.js index fb0bd0d..db86785 100644 --- a/www/login.js +++ b/www/login.js @@ -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(); + } } } diff --git a/www/main.js b/www/main.js new file mode 100644 index 0000000..85b5bde --- /dev/null +++ b/www/main.js @@ -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(); +}); diff --git a/www/messaging.js b/www/messaging.js new file mode 100644 index 0000000..d540422 --- /dev/null +++ b/www/messaging.js @@ -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); + } +} diff --git a/www/room.js b/www/room.js index b0b8b01..6dc74fa 100644 --- a/www/room.js +++ b/www/room.js @@ -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; - } } diff --git a/www/screen.js b/www/screen.js new file mode 100644 index 0000000..7be0953 --- /dev/null +++ b/www/screen.js @@ -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"; + } +} diff --git a/www/session.js b/www/session.js new file mode 100644 index 0000000..3cd1dcd --- /dev/null +++ b/www/session.js @@ -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; + } +} diff --git a/www/skin.css b/www/skin.css index c50993d..d716338 100644 --- a/www/skin.css +++ b/www/skin.css @@ -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"; } diff --git a/www/lib.js b/www/sort.js similarity index 73% rename from www/lib.js rename to www/sort.js index 9ad619c..6706aae 100644 --- a/www/lib.js +++ b/www/sort.js @@ -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)); - } }