Send a message containing the final score at the end
This commit is contained in:
parent
70e8981eb4
commit
683558d49c
3 changed files with 49 additions and 41 deletions
|
@ -16,20 +16,20 @@ import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers,
|
|||
|
||||
type Vertex = Session.Status
|
||||
|
||||
edges :: Vertex -> Message.FromClient -> App.T Vertex
|
||||
receive :: Vertex -> Message.FromClient -> App.T ()
|
||||
|
||||
edges (Session.LoggedIn False) logIn@(Message.LogIn login) =
|
||||
receive (Session.LoggedIn False) logIn@(Message.LogIn login) =
|
||||
asks App.key >>= App.try . (Server.logIn login)
|
||||
>>= maybe
|
||||
(Message.relay logIn Message.broadcast >> return (Session.LoggedIn True))
|
||||
(withError $ Session.LoggedIn False)
|
||||
(Message.relay logIn Message.broadcast >> move (Session.LoggedIn True))
|
||||
sendError
|
||||
|
||||
edges (Session.LoggedIn True) logOut@Message.LogOut = do
|
||||
receive (Session.LoggedIn True) logOut@Message.LogOut = do
|
||||
Message.relay logOut Message.broadcast
|
||||
asks App.key >>= App.update_ . Server.logOut
|
||||
return (Session.LoggedIn False)
|
||||
move (Session.LoggedIn False)
|
||||
|
||||
edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
|
||||
receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
|
||||
session <- App.get to
|
||||
case Session.status session of
|
||||
Session.LoggedIn True -> do
|
||||
|
@ -37,10 +37,10 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
|
|||
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])
|
||||
return (Session.Waiting to)
|
||||
_ -> Session.LoggedIn True `withError` "They just left"
|
||||
move (Session.Waiting to)
|
||||
_ -> sendError "They just left"
|
||||
|
||||
edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
|
||||
receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
|
||||
session <- App.get to
|
||||
key <- asks App.key
|
||||
case Session.status session of
|
||||
|
@ -51,48 +51,49 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
|
|||
then do
|
||||
gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
|
||||
game <- Server.get gameKey <$> App.server
|
||||
Message.notifyPlayers game []
|
||||
Message.notifyPlayers (KoiKoi.On game) []
|
||||
return $ Session.Playing gameKey
|
||||
else do
|
||||
Message.broadcast $ Message.update {Message.alone = [key, to]}
|
||||
return $ Session.LoggedIn True
|
||||
App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
|
||||
return newStatus
|
||||
_ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
|
||||
move newStatus
|
||||
_ -> sendError "They're not waiting for your answer"
|
||||
|
||||
edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do
|
||||
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 move game
|
||||
(result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game
|
||||
case result of
|
||||
Left message -> status `withError` message
|
||||
Left message -> sendError message
|
||||
Right newGame ->
|
||||
case newGame of
|
||||
KoiKoi.Over _ -> undefined
|
||||
KoiKoi.Over _ ->
|
||||
Message.notifyPlayers newGame logs
|
||||
KoiKoi.On on -> do
|
||||
App.update_ $ Server.update gameKey (const on)
|
||||
Message.notifyPlayers on logs
|
||||
return status
|
||||
Message.notifyPlayers newGame logs
|
||||
|
||||
edges state _ =
|
||||
state `withError` ("Invalid message in state " ++ show state)
|
||||
receive state _ = sendError $ "Invalid message in state " ++ show state
|
||||
|
||||
withError :: Vertex -> String -> App.T Vertex
|
||||
withError vertex message =
|
||||
(Message.send $ Message.Error message) >> return vertex
|
||||
sendError :: String -> App.T ()
|
||||
sendError = Message.send . Message.Error
|
||||
|
||||
run :: App.T ()
|
||||
run = do
|
||||
message <- Message.get
|
||||
status <- Session.status <$> App.current
|
||||
newStatus <- edges status message
|
||||
move :: Vertex -> App.T ()
|
||||
move newStatus = do
|
||||
key <- asks App.key
|
||||
App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
|
||||
App.debug $ show newStatus
|
||||
run
|
||||
|
||||
loop :: App.T ()
|
||||
loop = do
|
||||
message <- Message.get
|
||||
status <- Session.status <$> App.current
|
||||
status `receive` message
|
||||
loop
|
||||
|
||||
start :: App.T ()
|
||||
start = do
|
||||
App.debug "Initial state"
|
||||
Message.Welcome <$> App.server <*> asks App.key >>= Message.send
|
||||
run
|
||||
loop
|
||||
|
|
14
src/Game.hs
14
src/Game.hs
|
@ -48,6 +48,11 @@ deriving instance Generic On
|
|||
deriving instance Generic Over
|
||||
deriving instance Generic View
|
||||
|
||||
instance ToJSON On where
|
||||
toEncoding = genericToEncoding JSON.defaultOptions
|
||||
instance ToJSON Over where
|
||||
toEncoding = genericToEncoding JSON.defaultOptions
|
||||
|
||||
instance FromJSON Hanafuda.Card
|
||||
instance ToJSON Hanafuda.Card
|
||||
|
||||
|
@ -90,9 +95,7 @@ instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where
|
|||
toJSON = toJSON1
|
||||
toEncoding = toEncoding1
|
||||
|
||||
type T = Hanafuda.KoiKoi.On Player.Key
|
||||
|
||||
instance ToJSON T
|
||||
type T = On
|
||||
|
||||
type Key = Data.Key T
|
||||
|
||||
|
@ -100,8 +103,9 @@ 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 on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
|
||||
export :: Player.Key -> View -> Value
|
||||
export _ (Hanafuda.KoiKoi.Over over) = toJSON over
|
||||
export key (Hanafuda.KoiKoi.On on) = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
|
||||
where
|
||||
Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
|
||||
maskOpponentsHand k player
|
||||
|
|
|
@ -23,11 +23,11 @@ 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 Game (View, 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, On(..), Move(..))
|
||||
import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), On(..), Over(..), Move(..))
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
data FromClient =
|
||||
|
@ -98,7 +98,10 @@ get =
|
|||
update :: T
|
||||
update = Update {alone = [], paired = []}
|
||||
|
||||
notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
|
||||
notifyPlayers game logs =
|
||||
forM_ (keys $ KoiKoi.scores game) $ \k ->
|
||||
notifyPlayers :: Game.View -> [KoiKoi.Action] -> App.T ()
|
||||
notifyPlayers game@(KoiKoi.Over over) logs =
|
||||
forM_ (keys $ KoiKoi.finalScores over) $ \k ->
|
||||
sendTo [k] $ Game {game = Game.export k game, logs}
|
||||
notifyPlayers game@(KoiKoi.On on) logs =
|
||||
forM_ (keys $ KoiKoi.scores on) $ \k ->
|
||||
sendTo [k] $ Game {game = Game.export k game, logs}
|
||||
|
|
Loading…
Reference in a new issue