Use new PlayerKey type in lib and Message module from the separate APILanguage
This commit is contained in:
parent
d54d97b84d
commit
9d15a80ff5
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
43
src/Game.hs
43
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue