From e9205b67c7a5fabc840510ad4f0fd6c001afc221 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sat, 24 Aug 2019 23:29:40 +0200 Subject: [PATCH] Use the new APILanguage and simplify a lot of code --- ChangeLog.md | 5 ++ hanafuda-webapp.cabal | 21 ++++--- src/App.hs | 14 ++--- src/Automaton.hs | 87 +++++++++++++++-------------- src/Data.hs | 21 +------ src/Game.hs | 124 +++++++++--------------------------------- src/JSON.hs | 27 --------- src/Main.hs | 11 ++-- src/Message.hs | 105 ----------------------------------- src/Messaging.hs | 76 ++++++++++++++++++++++++++ src/Player.hs | 30 ---------- src/Server.hs | 75 +++++++++++-------------- src/Session.hs | 18 ++---- www/game.js | 26 +++++---- 14 files changed, 229 insertions(+), 411 deletions(-) delete mode 100644 src/JSON.hs delete mode 100644 src/Message.hs create mode 100644 src/Messaging.hs delete mode 100644 src/Player.hs diff --git a/ChangeLog.md b/ChangeLog.md index acef02a..8d85522 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for hanafudapi +## 0.2.3.0 -- 2019-08-24 + +* Huge refactoring to use the new APILanguage that basically vampirized Game module which become more of a toolbox for the Automaton +* Fix a couple race conditions in JS client and server encountered when developping and testing Hannah the bot soon to come + ## 0.2.2.0 -- 2019-08-12 * Handle the end of games diff --git a/hanafuda-webapp.cabal b/hanafuda-webapp.cabal index e5356e3..b22adf0 100644 --- a/hanafuda-webapp.cabal +++ b/hanafuda-webapp.cabal @@ -2,14 +2,14 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hanafuda-webapp -version: 0.2.2.0 +version: 0.2.3.0 synopsis: A webapp for the Haskell hanafuda library -- description: -homepage: https://framagit.org/hanafuda +homepage: https://git.marvid.fr/hanafuda license: BSD3 license-file: LICENSE -author: Sasha -maintainer: sasha+frama@marvid.fr +author: Tissevert +maintainer: tissevert+devel@marvid.fr -- copyright: category: Web build-type: Simple @@ -17,26 +17,25 @@ extra-source-files: ChangeLog.md cabal-version: >=1.10 source-repository head type: git - location: https://framagit.org/hanafuda/api + location: https://git.marvid.fr/hanafuda/webapp executable hanafudapi main-is: Main.hs other-modules: App , Automaton , Config - , Message + , Messaging , Game - , JSON , Data - , Player , Server , Session -- other-extensions: - build-depends: base >=4.10 && <4.13 + build-depends: base >=4.9 && <4.13 , bytestring - , containers + , containers >= 0.5.9 , unordered-containers - , hanafuda >= 0.3.0 + , hanafuda >= 0.3.3 + , hanafuda-APILanguage >= 0.1.0 , http-types , aeson , mtl diff --git a/src/App.hs b/src/App.hs index 9465550..4140e7c 100644 --- a/src/App.hs +++ b/src/App.hs @@ -16,13 +16,13 @@ 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 Hanafuda.KoiKoi (PlayerID) import qualified Session (T(..)) import qualified Server (T(..)) data Context = Context { mServer :: MVar Server.T - , key :: Player.Key + , playerID :: PlayerID } type T a = ReaderT Context IO a @@ -30,20 +30,20 @@ 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 +get :: PlayerID -> T Session.T +get playerID = + (! playerID) . Server.sessions <$> server current :: T Session.T current = do - asks key >>= get + asks playerID >>= get connection :: T Connection connection = Session.connection <$> current debug :: String -> T () debug message = - show <$> asks key + show <$> asks playerID >>= lift . putStrLn . (++ ' ':message) try :: (Server.T -> Either String Server.T) -> T (Maybe String) diff --git a/src/Automaton.hs b/src/Automaton.hs index 67e49d4..b6c18d0 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -3,99 +3,102 @@ module Automaton ( start ) where -import Control.Monad.Except (runExceptT) -import Control.Monad.Reader (asks, lift) -import Control.Monad.Writer (runWriterT) +import Control.Monad.Reader (asks) import qualified Data (RW(..)) import Data.Map (Map, (!?)) -import qualified Game (Key, T, new, play) -import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), Step(..)) +import qualified Game (new, play) +import qualified Hanafuda.KoiKoi as KoiKoi ( + Game, GameBlueprint(..), GameID, Step(..) + ) import qualified Session (Status(..), T(..), Update) -import qualified Server (endGame, get, logIn, logOut, update, register) -import qualified App (Context(..), T, current, debug, get, server, try, update, update_) -import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, update) +import qualified Server (endGame, get, logIn, logOut, update, room) +import qualified App (Context(..), T, current, debug, get, server, try, update_) +import qualified Hanafuda.Message as Message (FromClient(..), T(..)) +import qualified Messaging ( + broadcast, get, notifyPlayers, relay, send, sendTo, update + ) receive :: Session.Status -> Message.FromClient -> App.T () receive (Session.LoggedIn False) logIn@(Message.LogIn login) = - asks App.key >>= App.try . (Server.logIn login) + asks App.playerID >>= App.try . (Server.logIn login) >>= maybe - (Message.relay logIn Message.broadcast >> setSessionStatus (Session.LoggedIn True)) + (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True)) sendError receive (Session.LoggedIn True) logOut@Message.LogOut = do - Message.relay logOut Message.broadcast - asks App.key >>= App.update_ . Server.logOut + Messaging.relay logOut Messaging.broadcast + asks App.playerID >>= App.update_ . Server.logOut setSessionStatus (Session.LoggedIn False) receive (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.update to (Data.set $ Session.Answering key :: Session.Update)) - Message.broadcast $ Message.update {Message.paired = [key, to]} - (Message.relay invitation $ Message.sendTo [to]) + from <- asks App.playerID + App.update_ (Server.update to (Data.set $ Session.Answering from :: Session.Update)) + Messaging.broadcast $ Messaging.update {Message.paired = [from, to]} + (Messaging.relay invitation $ Messaging.sendTo [to]) setSessionStatus (Session.Waiting to) _ -> sendError "They just left" receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do session <- App.get to - key <- asks App.key + playerID <- asks App.playerID case Session.status session of - Session.Waiting for | for == key -> do - Message.relay message $ Message.sendTo [to] + Session.Waiting for | for == playerID -> do + Messaging.relay message $ Messaging.sendTo [to] newStatus <- if accept then do - gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update - game <- Server.get gameKey <$> App.server - Message.notifyPlayers game [] - return $ Session.Playing gameKey + gameID <- Game.new (for, to) + game <- Server.get gameID <$> App.server + Messaging.notifyPlayers game [] + return $ Session.Playing gameID else do - Message.broadcast $ Message.update {Message.alone = [key, to]} + Messaging.broadcast $ Messaging.update {Message.alone = [for, to]} return $ Session.LoggedIn True App.update_ $ Server.update to (Data.set newStatus :: Session.Update) setSessionStatus newStatus _ -> sendError "They're not waiting for your answer" -receive (Session.Playing gameKey) played@(Message.Play {}) = do - key <- asks App.key - game <- Server.get gameKey <$> App.server - (result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game +receive (Session.Playing gameID) played@(Message.Play {}) = do + playerID <- asks App.playerID + game <- Server.get gameID <$> App.server + (result, logs) <- Game.play playerID (Message.move played) game case result of Left message -> sendError message Right newGame -> do - Message.notifyPlayers newGame logs case KoiKoi.step newGame of KoiKoi.Over -> do - App.debug $ "Game " ++ show gameKey ++ " ended" - App.update_ $ Server.endGame gameKey - _ -> App.update_ $ Server.update gameKey (const newGame) + App.debug $ "Game " ++ show gameID ++ " ended" + App.update_ $ Server.endGame gameID + _ -> App.update_ $ Server.update gameID (const newGame) + Messaging.notifyPlayers newGame logs -receive (Session.Playing gameKey) Message.Quit = do - games <- (Data.get <$> App.server :: App.T (Map Game.Key Game.T)) - case games !? gameKey of +receive (Session.Playing gameID) Message.Quit = do + games <- (Data.get <$> App.server :: App.T (Map KoiKoi.GameID KoiKoi.Game)) + case games !? gameID of Nothing -> do - key <- asks App.key - Message.broadcast $ Message.update {Message.alone = [key]} + playerID <- asks App.playerID + Messaging.broadcast $ Messaging.update {Message.alone = [playerID]} setSessionStatus (Session.LoggedIn True) _ -> sendError "Game is still running" receive state _ = sendError $ "Invalid message in state " ++ show state sendError :: String -> App.T () -sendError = Message.send . Message.Error +sendError = Messaging.send . Message.Error setSessionStatus :: Session.Status -> App.T () setSessionStatus newStatus = do - key <- asks App.key - App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update) + playerID <- asks App.playerID + App.update_ $ Server.update playerID $ (Data.set newStatus :: Session.Update) App.debug $ show newStatus loop :: App.T () loop = do - message <- Message.get + message <- Messaging.get status <- Session.status <$> App.current status `receive` message loop @@ -103,5 +106,5 @@ loop = do start :: App.T () start = do App.debug "Initial state" - Message.Welcome <$> App.server <*> asks App.key >>= Message.send + Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send loop diff --git a/src/Data.hs b/src/Data.hs index c97b446..9e1e13a 100644 --- a/src/Data.hs +++ b/src/Data.hs @@ -1,30 +1,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} module Data ( - Key(..) - , RW(..) + 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 get :: b -> a set :: a -> b -> b 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 2b9cb47..f84059a 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -1,112 +1,40 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} module Game ( - Key - , T - , export + export , new , play ) where -import Control.Monad.Except (throwError) -import Data.Text (pack) +import qualified App (T, update) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Reader (lift) +import Control.Monad.Writer (runWriterT) import Data.Map (mapWithKey) -import Data.HashMap.Strict (insert) -import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), Value(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1) -import Data.Aeson.Types (toJSONKeyText) -import qualified JSON (defaultOptions, singleLCField) -import qualified Data (Key) -import qualified Player (Key) -import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty) +import qualified Hanafuda (empty) +import qualified Hanafuda.KoiKoi as KoiKoi ( + Action, Move(..), play, new + ) +import Hanafuda.KoiKoi (Game, GameBlueprint(..), GameID, Mode(..), PlayerID) import qualified Hanafuda.Player (Player(..), Players(..)) -import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play) -import GHC.Generics +import Hanafuda.Message (PublicGame) +import qualified Server (register) -deriving instance Generic Hanafuda.Card -deriving instance Generic Hanafuda.Flower -deriving instance Generic Hanafuda.KoiKoi.Action -deriving instance Generic Hanafuda.KoiKoi.Mode -deriving instance Generic Hanafuda.KoiKoi.Move -deriving instance Generic Hanafuda.KoiKoi.Yaku -deriving instance Generic Hanafuda.KoiKoi.Source -deriving instance Generic Hanafuda.KoiKoi.Step -deriving instance Generic1 (Hanafuda.Player.Player Player.Key) -deriving instance Generic1 (Hanafuda.Player.Players Player.Key) +new :: (PlayerID, PlayerID) -> App.T GameID +new (for, to) = + Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update -type T = Hanafuda.KoiKoi.Game Player.Key - -deriving instance Generic T - -instance ToJSON T where - toEncoding = genericToEncoding JSON.defaultOptions - -instance FromJSON Hanafuda.Card -instance ToJSON Hanafuda.Card - -instance ToJSON Hanafuda.Flower - -instance ToJSON Hanafuda.Pack where - toJSON = toJSON . Hanafuda.cardsOfPack - toEncoding = toEncoding . Hanafuda.cardsOfPack - -instance ToJSON Hanafuda.KoiKoi.Action - -instance ToJSON Hanafuda.KoiKoi.Mode - -instance FromJSON Hanafuda.KoiKoi.Move where - parseJSON = genericParseJSON JSON.singleLCField -instance ToJSON Hanafuda.KoiKoi.Move where - toEncoding = genericToEncoding JSON.singleLCField - -instance ToJSON Hanafuda.KoiKoi.Source - -instance ToJSON Hanafuda.KoiKoi.Step where - toEncoding = genericToEncoding JSON.defaultOptions - -instance ToJSON1 (Hanafuda.Player.Player Player.Key) where - liftToEncoding = genericLiftToEncoding JSON.defaultOptions - -instance ToJSON (Hanafuda.Player.Player Player.Key Hanafuda.KoiKoi.Score) where - toJSON = toJSON1 - toEncoding = toEncoding1 - -instance ToJSON Hanafuda.KoiKoi.Yaku where - toEncoding = genericToEncoding JSON.defaultOptions -instance ToJSONKey Hanafuda.KoiKoi.Yaku where - toJSONKey = toJSONKeyText (pack . show) - -instance ToJSON1 (Hanafuda.Player.Players Player.Key) where - liftToEncoding = genericLiftToEncoding JSON.defaultOptions - -instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where - toJSON = toJSON1 - toEncoding = toEncoding1 - -type Key = Data.Key T - -new :: Player.Key -> Player.Key -> IO T -new p1 p2 = do - Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.WholeYear - -export :: Player.Key -> T -> Value -export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast +export :: PlayerID -> Game -> PublicGame +export playerID game = game { + deck = length $ deck game + , players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered + } where Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game maskOpponentsHand k player - | k == key = player + | k == playerID = player | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty} - Object ast = toJSON $ game { - Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered - } -play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key) -play key move game - | Hanafuda.KoiKoi.playing game == key = - Hanafuda.KoiKoi.play move game - | otherwise = throwError "Not your turn" +play :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action]) +play playerID move game = lift . runWriterT . runExceptT $ + if playing game == playerID + then KoiKoi.play move game + else throwError "Not your turn" diff --git a/src/JSON.hs b/src/JSON.hs deleted file mode 100644 index 10100c6..0000000 --- a/src/JSON.hs +++ /dev/null @@ -1,27 +0,0 @@ -module JSON ( - defaultOptions - , distinct - , singleLCField - ) where - -import Data.Char (toLower) -import Data.Aeson ( - Options(..) - , SumEncoding(..) - , defaultOptions - ) - -first :: (a -> a) -> [a] -> [a] -first _ [] = [] -first f (x:xs) = f x:xs - -singleLCField :: Options -singleLCField = defaultOptions { - constructorTagModifier = (toLower `first`) - , sumEncoding = ObjectWithSingleField - } - -distinct :: Options -distinct = defaultOptions { - sumEncoding = UntaggedValue - } diff --git a/src/Main.hs b/src/Main.hs index af3515f..1290149 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,21 +14,22 @@ import qualified Config (listenPort) import qualified Session (open) import qualified Server (disconnect, new, register) import qualified App (Context(..), T, update_) -import qualified Message (FromClient(..), broadcast, relay) +import qualified Hanafuda.Message as Message (FromClient(..)) +import Messaging (broadcast, relay) import qualified Automaton (start) exit :: App.T () exit = do - asks App.key >>= App.update_ . Server.disconnect - Message.relay Message.LogOut Message.broadcast + asks App.playerID >>= App.update_ . Server.disconnect + relay Message.LogOut broadcast serverApp :: App.T () -> App.T () -> IO ServerApp serverApp onEnter onExit = do mServer <- newMVar Server.new return $ \pending -> do session <- Session.open <$> acceptRequest pending - key <- modifyMVar mServer (return . Server.register session) - let app = App.Context {App.mServer, App.key} + playerID <- modifyMVar mServer (return . Server.register session) + let app = App.Context {App.mServer, App.playerID} finally (runReaderT onEnter app) (runReaderT onExit app) diff --git a/src/Message.hs b/src/Message.hs deleted file mode 100644 index 5ef1771..0000000 --- a/src/Message.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -module Message ( - FromClient(..) - , T(..) - , broadcast - , get - , notifyPlayers - , receive - , relay - , send - , sendTo - , update - ) where - -import Data.List (intercalate) -import Data.Foldable (forM_) -import Data.Map (keys) -import Data.Aeson (FromJSON(..), ToJSON(..), Value, eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions) -import Network.WebSockets (receiveData, sendTextData) -import Data.ByteString.Lazy.Char8 (unpack) -import Data.Text (Text) -import Control.Monad.Reader (asks, lift) -import qualified Player (Key) -import qualified Game (T, export) -import qualified Session (T(..)) -import qualified Server (T(..), get) -import qualified App (Context(..), T, connection, debug, server) -import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), Move(..)) -import GHC.Generics (Generic) - -data FromClient = - Answer {accept :: Bool} - | Invitation {to :: Player.Key} - | LogIn {name :: Text} - | LogOut - | Play {move :: KoiKoi.Move} - | Quit - | Ping - deriving (Generic) - -instance ToJSON FromClient where - toEncoding = genericToEncoding defaultOptions -instance FromJSON FromClient where - parseJSON = genericParseJSON defaultOptions - -data T = - Relay {from :: Player.Key, message :: FromClient} - | Welcome {room :: Server.T, key :: Player.Key} - | Update {alone :: [Player.Key], paired :: [Player.Key]} - | Game {game :: Value, logs :: [KoiKoi.Action]} - | Pong - | Error {error :: String} - deriving (Generic) - -instance ToJSON T where - toEncoding = genericToEncoding defaultOptions - -sendTo :: [Player.Key] -> T -> App.T () -sendTo playerKeys obj = do - sessions <- getSessions <$> App.server - App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded) - lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded - where - encoded = encode $ obj - getSessions server = (\key -> Server.get key server) <$> playerKeys - recipients = show <$> playerKeys - -send :: T -> App.T () -send obj = do - key <- asks App.key - sendTo [key] obj - -broadcast :: T -> App.T () -broadcast obj = - App.server >>= flip sendTo obj . keys . Server.sessions - -relay :: FromClient -> (T -> App.T ()) -> App.T () -relay message f = do - App.debug "Relaying" - (\from -> f $ Relay {from, message}) =<< asks App.key - -receive :: App.T FromClient -receive = do - 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 :: App.T Message.FromClient -get = - receive >>= pong - where - pong Ping = send Pong >> get - pong m = return m - -update :: T -update = Update {alone = [], paired = []} - -notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T () -notifyPlayers game logs = - forM_ (keys $ KoiKoi.scores game) $ \k -> - sendTo [k] $ Game {game = Game.export k game, logs} diff --git a/src/Messaging.hs b/src/Messaging.hs new file mode 100644 index 0000000..53586a8 --- /dev/null +++ b/src/Messaging.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +module Messaging ( + FromClient(..) + , T(..) + , broadcast + , get + , notifyPlayers + , receive + , relay + , send + , sendTo + , update + ) where + +import Data.List (intercalate) +import Data.Foldable (forM_) +import Data.Map (keys) +import Data.Aeson (eitherDecode', encode) +import Network.WebSockets (receiveData, sendTextData) +import Data.ByteString.Lazy.Char8 (unpack) +import Control.Monad.Reader (asks, lift) +import qualified Game (export) +import qualified Session (T(..)) +import qualified Server (T(..), get) +import qualified App (Context(..), T, connection, debug, server) +import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game, GameBlueprint(..), PlayerID) +import qualified Hanafuda.Message as Message (T) +import Hanafuda.Message (FromClient(..), T(..)) + +sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T () +sendTo playerIDs obj = do + sessions <- getSessions <$> App.server + App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded) + lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded + where + encoded = encode $ obj + getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs + recipients = show <$> playerIDs + +send :: Message.T -> App.T () +send obj = do + playerID <- asks App.playerID + sendTo [playerID] obj + +broadcast :: Message.T -> App.T () +broadcast obj = + App.server >>= flip sendTo obj . keys . Server.sessions + +relay :: FromClient -> (Message.T -> App.T ()) -> App.T () +relay message f = do + App.debug "Relaying" + (\from -> f $ Relay {from, message}) =<< asks App.playerID + +receive :: App.T FromClient +receive = do + received <- ((lift . receiveData) =<< App.connection) + App.debug $ '>':(unpack received) + case eitherDecode' received of + Left errorMessage -> send (Error errorMessage) >> receive + Right clientMessage -> return clientMessage + +get :: App.T FromClient +get = + receive >>= pong + where + pong Ping = send Pong >> get + pong m = return m + +update :: T +update = Update {alone = [], paired = []} + +notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T () +notifyPlayers game logs = + forM_ (keys $ KoiKoi.scores game) $ \k -> + sendTo [k] $ Game {game = Game.export k game, logs} diff --git a/src/Player.hs b/src/Player.hs deleted file mode 100644 index e5a207e..0000000 --- a/src/Player.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Player ( - Key - , T(..) - ) where - -import Data.Text (Text) -import qualified Data (Key) -import GHC.Generics - -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 - -instance ToJSONKey Key where - toJSONKey = toJSONKeyText (pack . \(Key n) -> show n) - -instance FromJSON Name -instance ToJSON Name where - toEncoding = genericToEncoding JSON.defaultOptions --} diff --git a/src/Server.hs b/src/Server.hs index de9601f..e9b979a 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -2,9 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} module Server ( T(..) , disconnect @@ -14,25 +12,24 @@ module Server ( , logOut , new , register + , room , update ) where -import Data.Aeson (ToJSON(..), (.=), object, pairs) import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey) import qualified Data.Map as Map (empty) -import Data.Monoid ((<>)) import Data.Set (Set, member) import qualified Data.Set as Set (delete, empty, insert) import Data.Text (Text) +import Hanafuda.KoiKoi (Game, GameID, PlayerID) +import Hanafuda.Message (PlayerStatus(..), Room) import qualified Data (RW(..)) -import qualified Game (Key, T) -import qualified Player (Key, T(..)) import qualified Session (Status(..), T(..), Update) 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 +type Players = Map PlayerID Text +type Sessions = Map PlayerID Session.T +type Games = Map GameID Game data T = T { names :: Names , players :: Players @@ -56,22 +53,16 @@ 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) +export :: Sessions -> PlayerID -> Text -> PlayerStatus +export sessions playerID playerName = PlayerStatus (playerName, alone) where alone = - case Session.status (sessions ! key) of + case Session.status (sessions ! playerID) of Session.LoggedIn True -> True _ -> False -instance ToJSON T where - toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players - toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players +room :: T -> Room +room (T {players, sessions}) = mapWithKey (export sessions) players new :: T new = T { @@ -83,39 +74,39 @@ new = T { 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) + let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in + (Data.update (insert playerID x) server, playerID) 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 +get playerID server = (Data.get server :: Map a b) ! playerID update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T -update key updator = - Data.update (adjust updator key :: Map a b -> Map a b) +update playerID updator = + Data.update (adjust updator playerID :: Map a b -> Map a b) -disconnect :: Player.Key -> T -> T -disconnect key = - Data.update (delete key :: Sessions -> Sessions) . logOut key +disconnect :: PlayerID -> T -> T +disconnect playerID = + Data.update (delete playerID :: Sessions -> Sessions) . logOut playerID -endGame :: Game.Key -> T -> T -endGame key = - Data.update (delete key :: Games -> Games) +endGame :: GameID -> T -> T +endGame playerID = + Data.update (delete playerID :: Games -> Games) -logIn :: Text -> Player.Key -> T -> Either String T -logIn name key server = +logIn :: Text -> PlayerID -> T -> Either String T +logIn name playerID server = Data.update (Set.insert name) . - Data.update (insert key $ Player.T {Player.name}) . - update key (Data.set $ Session.LoggedIn True :: Session.Update) <$> + Data.update (insert playerID name) . + update playerID (Data.set $ Session.LoggedIn True :: Session.Update) <$> if name `member` names server then Left "This name is already registered" else Right server -logOut :: Player.Key -> T -> T -logOut key server = +logOut :: PlayerID -> T -> T +logOut playerID server = maybe server - (\player -> - Data.update (delete key :: Players -> Players) $ - update key (Data.set $ Session.LoggedIn False :: Session.Update) $ - Data.update (Set.delete $ Player.name player :: Names -> Names) server) - (players server !? key) + (\playerName -> + Data.update (delete playerID :: Players -> Players) $ + update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $ + Data.update (Set.delete playerName :: Names -> Names) server) + (players server !? playerID) diff --git a/src/Session.hs b/src/Session.hs index 37bc615..8937543 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} module Session ( Status(..) , T(..) @@ -9,22 +8,15 @@ module Session ( ) where import Network.WebSockets (Connection) -import Data.Aeson (ToJSON(..), genericToEncoding) -import GHC.Generics (Generic) -import qualified JSON (singleLCField) +import Hanafuda.KoiKoi (GameID, PlayerID) 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 + | Answering PlayerID + | Waiting PlayerID + | Playing GameID + deriving (Show) data T = T { connection :: Connection diff --git a/www/game.js b/www/game.js index 2e89dd8..f56079d 100644 --- a/www/game.js +++ b/www/game.js @@ -11,16 +11,6 @@ function Game(modules) { var selected = null; var queue = []; - window.addEventListener('focus', runQueue); - modules.messaging.addEventListener(["Game"], function(o) { - if(document.hasFocus()) { - modules.async.run(handleGameMessage(o)); - } else { - modules.statusHandler.set("♪"); - queue.push(handleGameMessage(o)); - } - }); - function buildSets() { var sets = {}; ['river', 'you', 'them'].forEach(function(id) { @@ -39,10 +29,24 @@ function Game(modules) { return sets; } + window.addEventListener('focus', runQueue); + modules.messaging.addEventListener(["Game"], function(o) { + queue.push(handleGameMessage(o)); + if(document.hasFocus() && queue.length == 1) { + runQueue(); + } else { + modules.statusHandler.set("♪"); + } + }); + function runQueue() { if(queue.length > 0) { + var length = queue.length; modules.async.run.apply(null, queue.concat( - modules.async.apply(function() {queue = [];}) + modules.async.apply(function() { + queue = queue.slice(length); + runQueue(); + }) )); } }