Follow renaming (Key -> ID) in hanafuda lib, finish taking IDs declaration out of the webapp and simplify Automaton by putting some operations back into Game module
This commit is contained in:
parent
539b74990e
commit
3e7c0a88f1
8 changed files with 110 additions and 153 deletions
14
src/App.hs
14
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 Hanafuda.KoiKoi (PlayerKey)
|
||||
import Hanafuda.KoiKoi (PlayerID)
|
||||
import qualified Session (T(..))
|
||||
import qualified Server (T(..))
|
||||
|
||||
data Context = Context {
|
||||
mServer :: MVar Server.T
|
||||
, key :: PlayerKey
|
||||
, 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 :: PlayerKey -> 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)
|
||||
|
|
|
@ -3,83 +3,85 @@ 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 (GameBlueprint(..), 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, room)
|
||||
import qualified App (Context(..), T, current, debug, get, server, try, update, 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)
|
||||
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
|
||||
(Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True))
|
||||
sendError
|
||||
|
||||
receive (Session.LoggedIn True) logOut@Message.LogOut = do
|
||||
Messaging.relay logOut Messaging.broadcast
|
||||
asks App.key >>= App.update_ . Server.logOut
|
||||
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))
|
||||
Messaging.broadcast $ Messaging.update {Message.paired = [key, 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
|
||||
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
|
||||
gameID <- Game.new (for, to)
|
||||
game <- Server.get gameID <$> App.server
|
||||
Messaging.notifyPlayers game []
|
||||
return $ Session.Playing gameKey
|
||||
return $ Session.Playing gameID
|
||||
else do
|
||||
Messaging.broadcast $ Messaging.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
|
||||
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
|
||||
Messaging.broadcast $ Messaging.update {Message.alone = [key]}
|
||||
playerID <- asks App.playerID
|
||||
Messaging.broadcast $ Messaging.update {Message.alone = [playerID]}
|
||||
setSessionStatus (Session.LoggedIn True)
|
||||
_ -> sendError "Game is still running"
|
||||
|
||||
|
@ -90,8 +92,8 @@ 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 ()
|
||||
|
@ -104,5 +106,5 @@ loop = do
|
|||
start :: App.T ()
|
||||
start = do
|
||||
App.debug "Initial state"
|
||||
Message.Welcome . Server.room <$> App.server <*> asks App.key >>= Messaging.send
|
||||
Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send
|
||||
loop
|
||||
|
|
21
src/Data.hs
21
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)
|
||||
|
|
51
src/Game.hs
51
src/Game.hs
|
@ -1,49 +1,40 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# 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 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 qualified Data (Key)
|
||||
import qualified Hanafuda (empty)
|
||||
import qualified Hanafuda.KoiKoi (Game, Environment, Mode(..), Move(..), PlayerKey, new, play)
|
||||
import Hanafuda.KoiKoi (GameBlueprint(..))
|
||||
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 Hanafuda.Message (PublicGame)
|
||||
import qualified Server (register)
|
||||
|
||||
new :: (PlayerID, PlayerID) -> App.T GameID
|
||||
new (for, to) =
|
||||
Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update
|
||||
|
||||
type T = Hanafuda.KoiKoi.Game
|
||||
|
||||
type Key = Data.Key T
|
||||
|
||||
new :: Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.PlayerKey -> IO T
|
||||
new p1 p2 = do
|
||||
Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.WholeYear
|
||||
|
||||
export :: Hanafuda.KoiKoi.PlayerKey -> T -> PublicGame
|
||||
export key game = game {
|
||||
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}
|
||||
|
||||
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
|
||||
| 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"
|
||||
|
|
|
@ -20,7 +20,7 @@ import qualified Automaton (start)
|
|||
|
||||
exit :: App.T ()
|
||||
exit = do
|
||||
asks App.key >>= App.update_ . Server.disconnect
|
||||
asks App.playerID >>= App.update_ . Server.disconnect
|
||||
relay Message.LogOut broadcast
|
||||
|
||||
serverApp :: App.T () -> App.T () -> IO ServerApp
|
||||
|
@ -28,8 +28,8 @@ 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)
|
||||
|
|
|
@ -20,28 +20,28 @@ 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 (T, export)
|
||||
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, GameBlueprint(..), PlayerKey)
|
||||
import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game, GameBlueprint(..), PlayerID)
|
||||
import qualified Hanafuda.Message as Message (T)
|
||||
import Hanafuda.Message (FromClient(..), T(..))
|
||||
|
||||
sendTo :: [KoiKoi.PlayerKey] -> Message.T -> App.T ()
|
||||
sendTo playerKeys obj = do
|
||||
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 = (\key -> Server.get key server) <$> playerKeys
|
||||
recipients = show <$> playerKeys
|
||||
getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs
|
||||
recipients = show <$> playerIDs
|
||||
|
||||
send :: Message.T -> App.T ()
|
||||
send obj = do
|
||||
key <- asks App.key
|
||||
sendTo [key] obj
|
||||
playerID <- asks App.playerID
|
||||
sendTo [playerID] obj
|
||||
|
||||
broadcast :: Message.T -> App.T ()
|
||||
broadcast obj =
|
||||
|
@ -50,7 +50,7 @@ broadcast obj =
|
|||
relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
|
||||
relay message f = do
|
||||
App.debug "Relaying"
|
||||
(\from -> f $ Relay {from, message}) =<< asks App.key
|
||||
(\from -> f $ Relay {from, message}) =<< asks App.playerID
|
||||
|
||||
receive :: App.T FromClient
|
||||
receive = do
|
||||
|
@ -70,7 +70,7 @@ get =
|
|||
update :: T
|
||||
update = Update {alone = [], paired = []}
|
||||
|
||||
notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
|
||||
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}
|
||||
|
|
|
@ -2,9 +2,7 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
module Server (
|
||||
T(..)
|
||||
, disconnect
|
||||
|
@ -23,17 +21,16 @@ import qualified Data.Map as Map (empty)
|
|||
import Data.Set (Set, member)
|
||||
import qualified Data.Set as Set (delete, empty, insert)
|
||||
import Data.Text (Text)
|
||||
import Hanafuda.KoiKoi (PlayerKey)
|
||||
import Hanafuda.KoiKoi (Game, GameID, PlayerID)
|
||||
import Hanafuda.Message (PlayerStatus(..), Room)
|
||||
import qualified Data (RW(..))
|
||||
import qualified Game (Key, T)
|
||||
import qualified Player (T(..))
|
||||
import qualified Session (Status(..), T(..), Update)
|
||||
|
||||
type Names = Set Text
|
||||
type Players = Map PlayerKey Player.T
|
||||
type Sessions = Map PlayerKey Session.T
|
||||
type Games = Map Game.Key Game.T
|
||||
type Players = Map PlayerID Player.T
|
||||
type Sessions = Map PlayerID Session.T
|
||||
type Games = Map GameID Game
|
||||
data T = T {
|
||||
names :: Names
|
||||
, players :: Players
|
||||
|
@ -57,23 +54,17 @@ instance Data.RW Games T where
|
|||
get = games
|
||||
set games server = server {games}
|
||||
|
||||
export :: Sessions -> PlayerKey -> Player.T -> PlayerStatus
|
||||
export sessions key player = PlayerStatus (Player.name player, alone)
|
||||
export :: Sessions -> PlayerID -> Player.T -> PlayerStatus
|
||||
export sessions playerID player = PlayerStatus (Player.name player, alone)
|
||||
where
|
||||
alone =
|
||||
case Session.status (sessions ! key) of
|
||||
case Session.status (sessions ! playerID) 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 {
|
||||
names = Set.empty
|
||||
|
@ -84,39 +75,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 :: PlayerKey -> 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 -> PlayerKey -> 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 $ Player.T {Player.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 :: PlayerKey -> 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 (delete playerID :: Players -> Players) $
|
||||
update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $
|
||||
Data.update (Set.delete $ Player.name player :: Names -> Names) server)
|
||||
(players server !? key)
|
||||
(players server !? playerID)
|
||||
|
|
|
@ -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 Hanafuda.KoiKoi (PlayerKey)
|
||||
import qualified JSON (singleLCField)
|
||||
import Hanafuda.KoiKoi (GameID, PlayerID)
|
||||
import qualified Data (RW(..))
|
||||
import qualified Game (Key)
|
||||
|
||||
data Status =
|
||||
LoggedIn Bool
|
||||
| Answering PlayerKey
|
||||
| Waiting PlayerKey
|
||||
| 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
|
||||
|
|
Loading…
Reference in a new issue