diff --git a/hanafuda-webapp.cabal b/hanafuda-webapp.cabal index e5356e3..5498d27 100644 --- a/hanafuda-webapp.cabal +++ b/hanafuda-webapp.cabal @@ -24,7 +24,7 @@ executable hanafudapi other-modules: App , Automaton , Config - , Message + , Messaging , Game , JSON , Data @@ -37,6 +37,7 @@ executable hanafudapi , containers , unordered-containers , hanafuda >= 0.3.0 + , hanafuda-APILanguage , http-types , aeson , mtl diff --git a/src/App.hs b/src/App.hs index 9465550..acb194a 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 (PlayerKey) import qualified Session (T(..)) import qualified Server (T(..)) data Context = Context { mServer :: MVar Server.T - , key :: Player.Key + , key :: PlayerKey } type T a = ReaderT Context IO a @@ -30,7 +30,7 @@ type T a = ReaderT Context IO a server :: T Server.T server = asks mServer >>= lift . readMVar -get :: Player.Key -> T Session.T +get :: PlayerKey -> T Session.T get key = (! key) . Server.sessions <$> server diff --git a/src/Automaton.hs b/src/Automaton.hs index 67e49d4..9813455 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -11,20 +11,21 @@ import Data.Map (Map, (!?)) import qualified Game (Key, T, new, play) import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), Step(..)) import qualified Session (Status(..), T(..), Update) -import qualified Server (endGame, get, logIn, logOut, update, register) +import qualified Server (endGame, get, logIn, logOut, update, register, room) 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 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) >>= 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 + Messaging.relay logOut Messaging.broadcast asks App.key >>= App.update_ . Server.logOut setSessionStatus (Session.LoggedIn False) @@ -34,8 +35,8 @@ receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = d 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]) + Messaging.broadcast $ Messaging.update {Message.paired = [key, to]} + (Messaging.relay invitation $ Messaging.sendTo [to]) setSessionStatus (Session.Waiting to) _ -> sendError "They just left" @@ -44,16 +45,16 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do key <- asks App.key case Session.status session of Session.Waiting for | for == key -> do - Message.relay message $ Message.sendTo [to] + 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 [] + Messaging.notifyPlayers game [] return $ Session.Playing gameKey else do - Message.broadcast $ Message.update {Message.alone = [key, to]} + Messaging.broadcast $ Messaging.update {Message.alone = [key, to]} return $ Session.LoggedIn True App.update_ $ Server.update to (Data.set newStatus :: Session.Update) setSessionStatus newStatus @@ -66,7 +67,7 @@ receive (Session.Playing gameKey) played@(Message.Play {}) = do case result of Left message -> sendError message Right newGame -> do - Message.notifyPlayers newGame logs + Messaging.notifyPlayers newGame logs case KoiKoi.step newGame of KoiKoi.Over -> do App.debug $ "Game " ++ show gameKey ++ " ended" @@ -78,14 +79,14 @@ receive (Session.Playing gameKey) Message.Quit = do case games !? gameKey of Nothing -> do key <- asks App.key - Message.broadcast $ Message.update {Message.alone = [key]} + Messaging.broadcast $ Messaging.update {Message.alone = [key]} 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 @@ -95,7 +96,7 @@ setSessionStatus newStatus = do loop :: App.T () loop = do - message <- Message.get + message <- Messaging.get status <- Session.status <$> App.current status `receive` message loop @@ -103,5 +104,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.key >>= Messaging.send loop diff --git a/src/Game.hs b/src/Game.hs index 2904580..8b29eff 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -18,29 +18,26 @@ import Control.Monad.Except (throwError) import Data.Text (pack) 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 (ToJSON(..), ToJSONKey(..), Value(..), defaultOptions, genericToEncoding) 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 (Flower(..), Pack, cardsOfPack, empty) +import qualified Hanafuda.KoiKoi (Game(..), Environment, Mode(..), Move(..), PlayerKey, Score, Step(..), Yaku(..), new, play) import qualified Hanafuda.Player (Player(..), Players(..)) -import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play) +import Hanafuda.Message() import GHC.Generics deriving instance Generic Hanafuda.Flower deriving instance Generic Hanafuda.KoiKoi.Mode deriving instance Generic Hanafuda.KoiKoi.Yaku deriving instance Generic Hanafuda.KoiKoi.Step -deriving instance Generic1 (Hanafuda.Player.Player Player.Key) -deriving instance Generic1 (Hanafuda.Player.Players Player.Key) -type T = Hanafuda.KoiKoi.Game Player.Key +type T = Hanafuda.KoiKoi.Game deriving instance Generic T instance ToJSON T where - toEncoding = genericToEncoding JSON.defaultOptions + toEncoding = genericToEncoding defaultOptions instance ToJSON Hanafuda.Flower @@ -51,34 +48,28 @@ instance ToJSON Hanafuda.Pack where instance ToJSON Hanafuda.KoiKoi.Mode instance ToJSON Hanafuda.KoiKoi.Step where - toEncoding = genericToEncoding JSON.defaultOptions + toEncoding = genericToEncoding 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.Player.Player Hanafuda.KoiKoi.Score) where + toJSON = toJSON + toEncoding = toEncoding instance ToJSON Hanafuda.KoiKoi.Yaku where - toEncoding = genericToEncoding JSON.defaultOptions + toEncoding = genericToEncoding 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 +instance ToJSON (Hanafuda.Player.Players Hanafuda.KoiKoi.Score) where + toJSON = toJSON + toEncoding = toEncoding type Key = Data.Key T -new :: Player.Key -> Player.Key -> IO T +new :: Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.PlayerKey -> IO T new p1 p2 = do Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.WholeYear -export :: Player.Key -> T -> Value +export :: Hanafuda.KoiKoi.PlayerKey -> T -> Value export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast where Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game @@ -89,7 +80,7 @@ export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck 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 :: Hanafuda.KoiKoi.Environment m => Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.Move -> T -> m T play key move game | Hanafuda.KoiKoi.playing game == key = Hanafuda.KoiKoi.play move game diff --git a/src/Main.hs b/src/Main.hs index af3515f..abb1ee8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,13 +14,14 @@ 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 + relay Message.LogOut broadcast serverApp :: App.T () -> App.T () -> IO ServerApp serverApp onEnter onExit = do diff --git a/src/Message.hs b/src/Messaging.hs similarity index 75% rename from src/Message.hs rename to src/Messaging.hs index 1720ef0..a19df27 100644 --- a/src/Message.hs +++ b/src/Messaging.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -module Message ( +module Messaging ( FromClient(..) , T(..) , broadcast @@ -17,20 +16,19 @@ module Message ( import Data.List (intercalate) import Data.Foldable (forM_) import Data.Map (keys) -import Data.Aeson (FromJSON(..), ToJSON(..), Value, eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions) +import Data.Aeson (eitherDecode', encode) 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) +import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerKey) +import qualified Hanafuda.Message as Message (T) +import Hanafuda.Message (FromClient(..), T(..)) -sendTo :: [Player.Key] -> T -> App.T () +sendTo :: [KoiKoi.PlayerKey] -> Message.T -> App.T () sendTo playerKeys obj = do sessions <- getSessions <$> App.server App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded) @@ -40,16 +38,16 @@ sendTo playerKeys obj = do getSessions server = (\key -> Server.get key server) <$> playerKeys recipients = show <$> playerKeys -send :: T -> App.T () +send :: Message.T -> App.T () send obj = do key <- asks App.key sendTo [key] obj -broadcast :: T -> App.T () +broadcast :: Message.T -> App.T () broadcast obj = App.server >>= flip sendTo obj . keys . Server.sessions -relay :: FromClient -> (T -> App.T ()) -> App.T () +relay :: FromClient -> (Message.T -> App.T ()) -> App.T () relay message f = do App.debug "Relaying" (\from -> f $ Relay {from, message}) =<< asks App.key @@ -59,10 +57,10 @@ receive = do received <- ((lift . receiveData) =<< App.connection) App.debug $ '>':(unpack received) case eitherDecode' received of - Left errorMessage -> send (Message.Error errorMessage) >> receive + Left errorMessage -> send (Error errorMessage) >> receive Right clientMessage -> return clientMessage -get :: App.T Message.FromClient +get :: App.T FromClient get = receive >>= pong where diff --git a/src/Player.hs b/src/Player.hs index e5a207e..7647638 100644 --- a/src/Player.hs +++ b/src/Player.hs @@ -3,18 +3,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Player ( - Key - , T(..) + 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 diff --git a/src/Server.hs b/src/Server.hs index de9601f..baf0278 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -14,24 +14,25 @@ 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 (PlayerKey) +import Hanafuda.Message (PlayerStatus(..), Room) import qualified Data (RW(..)) import qualified Game (Key, T) -import qualified Player (Key, T(..)) +import qualified Player (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 Players = Map PlayerKey Player.T +type Sessions = Map PlayerKey Session.T type Games = Map Game.Key Game.T data T = T { names :: Names @@ -56,22 +57,22 @@ 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 -> PlayerKey -> Player.T -> PlayerStatus +export sessions key player = PlayerStatus (Player.name player, alone) where alone = case Session.status (sessions ! key) of Session.LoggedIn True -> True _ -> False +room :: T -> Room +room (T {players, sessions}) = mapWithKey (export sessions) players + +{- instance ToJSON T where toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players +-} new :: T new = T { @@ -93,7 +94,7 @@ 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) -disconnect :: Player.Key -> T -> T +disconnect :: PlayerKey -> T -> T disconnect key = Data.update (delete key :: Sessions -> Sessions) . logOut key @@ -101,7 +102,7 @@ endGame :: Game.Key -> T -> T endGame key = Data.update (delete key :: Games -> Games) -logIn :: Text -> Player.Key -> T -> Either String T +logIn :: Text -> PlayerKey -> T -> Either String T logIn name key server = Data.update (Set.insert name) . Data.update (insert key $ Player.T {Player.name}) . @@ -110,7 +111,7 @@ logIn name key server = then Left "This name is already registered" else Right server -logOut :: Player.Key -> T -> T +logOut :: PlayerKey -> T -> T logOut key server = maybe server diff --git a/src/Session.hs b/src/Session.hs index 37bc615..226c650 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -11,15 +11,15 @@ module Session ( import Network.WebSockets (Connection) import Data.Aeson (ToJSON(..), genericToEncoding) import GHC.Generics (Generic) +import Hanafuda.KoiKoi (PlayerKey) 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 + | Answering PlayerKey + | Waiting PlayerKey | Playing Game.Key deriving (Show, Generic)