Send a message containing the final score at the end

This commit is contained in:
Tissevert 2019-01-15 23:14:07 +01:00
parent 70e8981eb4
commit 683558d49c
3 changed files with 49 additions and 41 deletions

View file

@ -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

View file

@ -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

View file

@ -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}