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