hanafuda/server
1
1
Fork 0
Code Issues Pull requests Releases Wiki Activity

Use new parametric Game type in hanafuda library to expose Games more easily

Browse source
This commit is contained in:
Sasha 2018-05-15 18:21:07 +02:00
parent 83201d5c95
commit 4cd6842c01
5 changed files with 94 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
src/Automaton.hs
View file

@ -3,14 +3,13 @@ module Automaton (
start
) where
import Data.Foldable (forM_)
import Control.Monad.Reader (asks, lift)
import qualified Data (RW(..))
import qualified Game (export, new)
import qualified Game (Game(..), T(..), new, play)
import qualified Session (Status(..), T(..), Update)
import qualified Server (get, logIn, logOut, update, register)
import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo, update)
import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, update)
type Vertex = Session.Status
@ -34,7 +33,7 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = 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, session)])
(Message.relay invitation $ Message.sendTo [to])
return (Session.Waiting to)
_ -> Session.LoggedIn True `withError` "They just left"
@ -43,25 +42,32 @@ edges (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, session)]
Message.relay message $ Message.sendTo [to]
newStatus <-
if accept
then do
gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
game <- Server.get gameKey <$> App.server
current <- App.current
forM_ [(to, session), (key, current)] $ \(k, s) ->
Message.sendTo [(k, s)] $ Message.NewGame {Message.game = Game.export k game}
Message.notifyPlayers game
return $ Session.Playing gameKey
else do
Message.broadcast $ Message.update {Message.alone = [key, to]}
return $ Session.LoggedIn True
App.update_ $ Server.update for (Data.set newStatus :: Session.Update)
App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
return newStatus
_ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
--edges (Session.Playing game) message@(Message.Play {Message.move}) = do
edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do
key <- asks App.key
game <- Server.get gameKey <$> App.server
newGame <- lift $ Game.play key move game
case Game.state newGame of
Game.Error s -> status `withError` s
Game.Over _ -> undefined
Game.On _ -> do
App.update_ $ Server.update gameKey (const newGame)
Message.notifyPlayers newGame
return status
edges state _ =
state `withError` ("Invalid message in state " ++ show state)

92
src/Game.hs
View file

@ -3,24 +3,28 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Game (
Key
, View(..)
Hanafuda.KoiKoi.Game(..)
, Key
, View
, T(..)
, export
, new
, play
) where
import Data.Text (pack)
import Data.Map (Map, (!), fromList, mapKeys, mapWithKey)
import Data.Map (Map, (!), fromList, mapWithKey)
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
import Data.Aeson.Types (toJSONKeyText)
import qualified JSON (defaultOptions, singleLCField)
import qualified Data (Key)
import qualified JSON (defaultOptions, distinct, singleLCField)
import qualified Data (Key, RW(..))
import qualified Player (Key)
import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
import qualified Hanafuda.Player (Player(..), Seat(..), Points)
import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), Score, Step(..), Yaku(..), new)
import qualified Hanafuda.Player (Player(..), Seat(..))
import qualified Hanafuda.KoiKoi.Game (remap)
import qualified Hanafuda.KoiKoi (Game(..), Mode(..), Move(..), On(..), Over(..), Score, Step(..), Yaku(..), new, play)
import GHC.Generics
deriving instance Generic Hanafuda.Card
@ -31,6 +35,14 @@ deriving instance Generic Hanafuda.KoiKoi.Yaku
deriving instance Generic Hanafuda.KoiKoi.Step
deriving instance Generic1 Hanafuda.Player.Player
type On = Hanafuda.KoiKoi.On Player.Key
type Over = Hanafuda.KoiKoi.Over Player.Key
type View = Hanafuda.KoiKoi.Game Player.Key
deriving instance Generic On
deriving instance Generic Over
deriving instance Generic View
instance FromJSON Hanafuda.Card
instance ToJSON Hanafuda.Card
@ -62,57 +74,49 @@ instance ToJSONKey Hanafuda.KoiKoi.Yaku where
instance ToJSON Hanafuda.KoiKoi.Step where
toEncoding = genericToEncoding JSON.defaultOptions
instance ToJSON On
instance ToJSON Over
instance ToJSON View where
toEncoding = genericToEncoding JSON.distinct
data T = T {
keys :: Map Hanafuda.Player.Seat Player.Key
, seats :: Map Player.Key Hanafuda.Player.Seat
, state :: Hanafuda.KoiKoi.On
, state :: Hanafuda.KoiKoi.Game Hanafuda.Player.Seat
}
type Key = Data.Key T
type Players a = Map Player.Key a
data View = View {
mode :: Hanafuda.KoiKoi.Mode
, scores :: Players Hanafuda.Player.Points
, month :: Hanafuda.Flower
, players :: Players (Hanafuda.Player.Player Hanafuda.KoiKoi.Score)
, playing :: Player.Key
, winning :: Player.Key
, oyake :: Player.Key
, river :: [Hanafuda.Card]
, step :: Hanafuda.KoiKoi.Step
, trick :: [Hanafuda.Card]
} deriving (Generic)
instance ToJSON View where
toEncoding = genericToEncoding JSON.singleLCField
instance Data.RW (Hanafuda.KoiKoi.Game Hanafuda.Player.Seat) T where
get = state
set state game = game {state}
new :: Player.Key -> Player.Key -> IO T
new p1 p2 = do
state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
on <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
return $ T {
keys = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
, seats = fromList [(p1, Hanafuda.Player.Player1), (p2, Hanafuda.Player.Player2)]
, state
, state = Hanafuda.KoiKoi.On on
}
export :: Player.Key -> T -> View
export key (T {keys, state}) = View {
mode = Hanafuda.KoiKoi.mode state
, scores = reindex $ Hanafuda.KoiKoi.scores state
, month = Hanafuda.KoiKoi.month state
, players = mapWithKey (\k -> if k == key then id else maskHand) players
, playing = keys ! Hanafuda.KoiKoi.playing state
, winning = keys ! Hanafuda.KoiKoi.winning state
, oyake = keys ! Hanafuda.KoiKoi.oyake state
, river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
, step = Hanafuda.KoiKoi.step state
, trick = Hanafuda.KoiKoi.trick state
export key (T {keys, state}) =
case Hanafuda.KoiKoi.Game.remap (keys !) state of
view@(Hanafuda.KoiKoi.Error _) -> view
view@(Hanafuda.KoiKoi.Over _) -> view
(Hanafuda.KoiKoi.On on) -> Hanafuda.KoiKoi.On $ on {
Hanafuda.KoiKoi.stock = []
, Hanafuda.KoiKoi.players = mapWithKey maskOpponentsHand $ Hanafuda.KoiKoi.players on
}
where
reindex = mapKeys (keys !)
players = reindex $ Hanafuda.KoiKoi.players state
maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty}
maskOpponentsHand k player
| k == key = player
| otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> T
play = undefined
play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> IO T
play key move game@(T {keys, state = Hanafuda.KoiKoi.On on})
| keys ! Hanafuda.KoiKoi.playing on == key = do
newState <- Hanafuda.KoiKoi.play move on
return $ game {state = newState}
| otherwise = return $ game {state = Hanafuda.KoiKoi.Error "Not your turn"}
play _ _ game = return $ game {state = Hanafuda.KoiKoi.Error "This game is over"}

6
src/JSON.hs
View file

@ -1,5 +1,6 @@
module JSON (
defaultOptions
, distinct
, singleLCField
) where
@ -19,3 +20,8 @@ singleLCField = defaultOptions {
constructorTagModifier = (toLower `first`)
, sumEncoding = ObjectWithSingleField
}
distinct :: Options
distinct = defaultOptions {
sumEncoding = UntaggedValue
}

36
src/Message.hs
View file

@ -1,10 +1,12 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
module Message (
FromClient(..)
, T(..)
, broadcast
, get
, notifyPlayers
, receive
, relay
, send
@ -14,17 +16,17 @@ module Message (
import Data.List (intercalate)
import Data.Foldable (forM_)
import Data.Map (toList)
import Data.Map (elems, keys)
import Data.Aeson (FromJSON(..), ToJSON(..), 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 (View)
import qualified Game (T(..), View, export)
import qualified Session (T(..))
import qualified Server (T(..))
import qualified App (Context(..), T, connection, current, debug, server)
import qualified Server (T(..), get)
import qualified App (Context(..), T, connection, debug, server)
import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
import GHC.Generics (Generic)
@ -46,7 +48,7 @@ data T =
Relay {from :: Player.Key, message :: FromClient}
| Welcome {room :: Server.T, key :: Player.Key}
| Update {alone :: [Player.Key], paired :: [Player.Key]}
| NewGame {game :: Game.View}
| Game {game :: Game.View}
| Pong
| Error {error :: String}
deriving (Generic)
@ -54,25 +56,24 @@ data T =
instance ToJSON T where
toEncoding = genericToEncoding defaultOptions
sendTo :: [(Player.Key, Session.T)] -> T -> App.T ()
sendTo sessions obj = do
sendTo :: [Player.Key] -> T -> App.T ()
sendTo playerKeys obj = do
sessions <- getSessions <$> App.server
App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
lift $ forM_ connections $ flip sendTextData encoded
lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded
where
encoded = encode $ obj
(recipients, connections) = unzip [
(show key, Session.connection session) | (key, session) <- sessions
]
getSessions server = (\key -> Server.get key server) <$> playerKeys
recipients = show <$> playerKeys
send :: T -> App.T ()
send obj = do
key <- asks App.key
session <- App.current
sendTo [(key, session)] obj
sendTo [key] obj
broadcast :: T -> App.T ()
broadcast obj =
App.server >>= flip sendTo obj . toList . Server.sessions
App.server >>= flip sendTo obj . keys . Server.sessions
relay :: FromClient -> (T -> App.T ()) -> App.T ()
relay message f = do
@ -96,3 +97,10 @@ get =
update :: T
update = Update {alone = [], paired = []}
notifyPlayers :: Game.T -> App.T ()
notifyPlayers game =
forM_ playerKeys $ \k ->
sendTo [k] $ Game {game = Game.export k game}
where
playerKeys = elems $ Game.keys game

7
src/Server.hs
View file

@ -88,9 +88,6 @@ register x server =
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
set :: forall a b c. (Ord a, Data.RW (Map a b) T, Data.RW c b) => a -> c -> T -> T
set key value = update key (Data.set value :: b -> b)
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)
@ -117,7 +114,3 @@ logOut key server =
update key (Data.set $ Session.LoggedIn False :: Session.Update) $
Data.update (Set.delete $ Player.name player :: Names -> Names) server)
(players server !? key)
setStatus :: Session.Status -> Player.Key -> T -> T
setStatus status key =
Data.update (adjust (Data.set status) key :: Sessions -> Sessions)