From 81ec84abaf41606c84e9796aaede615ce7d8772e Mon Sep 17 00:00:00 2001 From: Tissevert Date: Mon, 20 Jan 2020 22:58:06 +0100 Subject: [PATCH] Follow move of 'logs' into PublicGame and start implementing re-sync protocol on the server side --- src/Automaton.hs | 36 ++++++++++++++++++++++++++---------- src/Game.hs | 16 +++++++++------- src/Messaging.hs | 11 +++++------ 3 files changed, 40 insertions(+), 23 deletions(-) diff --git a/src/Automaton.hs b/src/Automaton.hs index bfdd454..3153bc4 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -5,8 +5,12 @@ module Automaton ( import qualified App (Context(..), T, exec, get, player, update) import Control.Monad.Reader (asks) -import qualified Game (new, play) -import qualified Hanafuda.Message as Message (FromClient(..), T(..)) +import Data.Map ((!)) +import qualified Game (fromPublic, new, play, toPublic) +import qualified Hanafuda.KoiKoi as KoiKoi (Game(..)) +import qualified Hanafuda.Message as Message ( + FromClient(..), PublicGame(..), T(..) + ) import qualified Messaging ( broadcast, get, notifyPlayers, relay, send, sendTo ) @@ -38,22 +42,31 @@ receive (Message.Tadaima {Message.myID, Message.name}) Nothing = do receive (Message.Tadaima {}) (Just _) = sendError "You're already logged in" -receive invitation@(Message.Invitation {Message.to}) (Just _) = - Messaging.relay invitation (Messaging.sendTo [to]) +receive invitation@(Message.Invitation {}) (Just _) = relay invitation receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) = if accept then do publicGames <- Game.new (Player.playerID player, to) Messaging.relay answer (Messaging.sendTo [to]) - Messaging.notifyPlayers publicGames [] + Messaging.notifyPlayers (publicGames, []) else Messaging.relay answer (Messaging.sendTo [to]) -receive (Message.Play {Message.move, Message.onGame}) (Just player) = do - result <- Game.play (Player.playerID player) move onGame - case result of - Left message -> sendError message - Right (newGame, logs) -> Messaging.notifyPlayers newGame logs +receive (Message.Play {Message.move, Message.onGame}) (Just player) = + Game.play (Player.playerID player) move onGame + >>= either sendError Messaging.notifyPlayers + +receive sync@(Message.Sync {}) (Just _) = relay sync +receive yield@(Message.Yield {}) (Just _) = relay yield + +receive (Message.Share {Message.gameSave}) (Just player) = + either sendError share =<< Game.fromPublic gameSave + where + logs = Message.logs gameSave + share game = + let recipientID = KoiKoi.nextPlayer game ! (Player.playerID player) in + Game.toPublic recipientID game logs + >>= Messaging.sendTo [recipientID] . Message.Game receive message state = sendError $ "Invalid message " ++ show message ++ " in " ++ showState @@ -63,6 +76,9 @@ receive message state = Nothing -> "disconnected state" Just _ -> "connected state" +relay :: Message.FromClient -> App.T () +relay message = Messaging.relay message (Messaging.sendTo [Message.to message]) + sendError :: String -> App.T () sendError = Messaging.send . Message.Error diff --git a/src/Game.hs b/src/Game.hs index 099d4e8..065d263 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -1,8 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} module Game ( - exportGame + fromPublic , new , play + , toPublic ) where import qualified App (T, get) @@ -86,12 +87,13 @@ publicState coordinates game = PublicState { , rounds = KoiKoi.rounds game } -exportGame :: PlayerID -> Game -> App.T PublicGame -exportGame playerID game = do +toPublic :: PlayerID -> Game -> [KoiKoi.Action] -> App.T PublicGame +toPublic playerID game logs = do Keys.T {encrypt, sign} <- App.get Server.keys n <- lift newNonce return $ PublicGame { nonce = Saltine.encode n + , logs , playerHand = getHand playerID (KoiKoi.players game) , private = secretbox encrypt n $ toJSON private , public @@ -124,8 +126,8 @@ merge public private = KoiKoi.Game { , KoiKoi.rounds = rounds public } -importGame :: PublicGame -> App.T (Either String Game) -importGame PublicGame {nonce, private, public, publicSignature} = +fromPublic :: PublicGame -> App.T (Either String Game) +fromPublic PublicGame {nonce, private, public, publicSignature} = App.get Server.keys >>= \(Keys.T {encrypt, sign}) -> return $ do check (signVerifyDetached (Keys.public sign) publicSignature (toJSON public)) `orDie` "The game state has been tampered with" @@ -145,8 +147,8 @@ importGame PublicGame {nonce, private, public, publicSignature} = play :: PlayerID -> KoiKoi.Move -> PublicGame -> App.T (Either String (Game, [KoiKoi.Action])) play playerID move publicGame | playing (public publicGame) == playerID = do - imported <- importGame publicGame - case imported of + result <- fromPublic publicGame + case result of Left errorMessage -> return $ Left errorMessage Right game -> lift . runExceptT . runWriterT $ KoiKoi.play move game | otherwise = return $ Left "Not your turn" diff --git a/src/Messaging.hs b/src/Messaging.hs index a4bd1b6..689f585 100644 --- a/src/Messaging.hs +++ b/src/Messaging.hs @@ -21,7 +21,7 @@ import Data.List (intercalate) import Data.Map (elems, keys) import Data.Maybe (maybeToList) import qualified Data.Set as Set (fromList, member) -import qualified Game (exportGame) +import qualified Game (toPublic) import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID) import Hanafuda.Message (FromClient(..), T(..)) import qualified Hanafuda.Message as Message (T) @@ -78,8 +78,7 @@ get = pong Ping = send Pong >> get pong m = return m -notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T () -notifyPlayers game logs = - forM_ (keys $ KoiKoi.scores game) $ \k -> do - state <- Game.exportGame k game - sendTo [k] $ Game {state, logs} +notifyPlayers :: (KoiKoi.Game, [KoiKoi.Action]) -> App.T () +notifyPlayers (game, logs) = + forM_ (keys $ KoiKoi.nextPlayer game) $ \k -> + sendTo [k] . Game =<< Game.toPublic k game logs