diff --git a/src/Automaton.hs b/src/Automaton.hs index a896457..284071e 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -62,18 +62,17 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do setSessionStatus newStatus _ -> sendError "They're not waiting for your answer" -receive (Session.Playing gameID) played@(Message.Play {}) = do +receive (Session.Playing gameID) (Message.Play {Message.move, Message.onGame}) = do playerID <- asks App.playerID - game <- Server.get gameID <$> App.server - (result, logs) <- Game.play playerID (Message.move played) game + result <- Game.play playerID move onGame case result of Left message -> sendError message - Right newGame -> do + Right (newGame, logs) -> do case KoiKoi.step newGame of KoiKoi.Over -> do App.debug $ "Game " ++ show gameID ++ " ended" App.update_ $ Server.endGame gameID - _ -> App.update_ $ Server.update gameID (const newGame) + _ -> return () Messaging.notifyPlayers newGame logs receive (Session.Playing gameID) Message.Quit = do diff --git a/src/Game.hs b/src/Game.hs index a162be6..2b99ecf 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -1,29 +1,30 @@ {-# LANGUAGE NamedFieldPuns #-} module Game ( - export + exportGame , new , play ) where import qualified App (T, server, update) -import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Except (runExceptT) import Control.Monad.Reader (lift) import Control.Monad.Writer (runWriterT) import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..)) -import Crypto.Saltine.Core.SecretBox (newNonce, secretbox) -import Crypto.Saltine.Core.Sign (signDetached) -import Data.Aeson (ToJSON, encode) +import Crypto.Saltine.Core.SecretBox (newNonce, secretbox, secretboxOpen) +import Crypto.Saltine.Core.Sign (signDetached, signVerifyDetached) +import Data.Aeson (ToJSON, eitherDecode', encode) import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) -import Data.Map (Map) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Map ((!), Map, mapWithKey) import qualified Hanafuda (Pack) import Hanafuda.KoiKoi (Game, GameID, Mode(..), Player, PlayerID, Players) import qualified Hanafuda.KoiKoi as KoiKoi ( Action, Game(..), Move(..), play, new ) import Hanafuda.Message (PrivateState(..), PublicGame(..), PublicPlayer(..), PublicState(..)) -import qualified Hanafuda.Player as Player (Player(..), Players(..), get, next) -import Keys (T(..), secret) +import qualified Hanafuda.Player as Player (Player(..), Players(..), get) +import Keys (T(..)) +import qualified Keys (public, secret) import qualified Server (T(..), register) new :: (PlayerID, PlayerID) -> App.T GameID @@ -35,14 +36,13 @@ exportPlayers game = let (Player.Players players) = KoiKoi.players game in players -privateState :: PlayerID -> Game -> PrivateState -privateState playerID game = PrivateState { - opponentHand = getHand opponentID players +privateState :: Game -> PrivateState +privateState game = PrivateState { + hands = Player.hand <$> players , deck = KoiKoi.deck game } where - players = KoiKoi.players game - opponentID = Player.next players playerID + Player.Players players = KoiKoi.players game getHand :: PlayerID -> Players -> Hanafuda.Pack getHand playerID = Player.hand . (Player.get playerID) @@ -53,11 +53,19 @@ publicPlayer player = PublicPlayer { , yakus = Player.yakus player } +privatePlayer :: Map PlayerID PublicPlayer -> PlayerID -> Hanafuda.Pack -> Player +privatePlayer publicPlayers playerID hand = Player.Player { + Player.hand + , Player.meld = meld (publicPlayers ! playerID) + , Player.yakus = yakus (publicPlayers ! playerID) + } + publicState :: Game -> PublicState publicState game = PublicState { mode = KoiKoi.mode game , scores = KoiKoi.scores game , month = KoiKoi.month game + , nextPlayer = KoiKoi.nextPlayer game , players = publicPlayer <$> exportPlayers game , playing = KoiKoi.playing game , winning = KoiKoi.winning game @@ -69,8 +77,8 @@ publicState game = PublicState { , rounds = KoiKoi.rounds game } -export :: PlayerID -> Game -> App.T PublicGame -export playerID game = do +exportGame :: PlayerID -> Game -> App.T PublicGame +exportGame playerID game = do Keys.T {encrypt, sign} <- Server.keys <$> App.server n <- lift newNonce return $ PublicGame { @@ -78,16 +86,52 @@ export playerID game = do , playerHand = getHand playerID (KoiKoi.players game) , private = secretbox encrypt n $ toJSON private , public - , publicSignature = signDetached (secret sign) $ toJSON public + , publicSignature = signDetached (Keys.secret sign) $ toJSON public } where public = publicState game - private = privateState playerID game - toJSON :: ToJSON a => a -> ByteString - toJSON = toStrict . encode + private = privateState game -play :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action]) -play playerID move game = lift . runWriterT . runExceptT $ - if KoiKoi.playing game == playerID - then KoiKoi.play move game - else throwError "Not your turn" +toJSON :: ToJSON a => a -> ByteString +toJSON = toStrict . encode + +gameOf :: PublicState -> PrivateState -> Game +gameOf public private = KoiKoi.Game { + KoiKoi.mode = mode public + , KoiKoi.scores = scores public + , KoiKoi.month = month public + , KoiKoi.nextPlayer = nextPlayer public + , KoiKoi.players = Player.Players $ + mapWithKey (privatePlayer $ players public) (hands private) + , KoiKoi.playing = playing public + , KoiKoi.winning = winning public + , KoiKoi.oyake = winning public + , KoiKoi.deck = deck private + , KoiKoi.river = river public + , KoiKoi.step = step public + , KoiKoi.trick = trick public + , KoiKoi.rounds = rounds public + } + +importGame :: PublicGame -> App.T (Either String Game) +importGame PublicGame {nonce, private, public, publicSignature} = do + Keys.T {encrypt, sign} <- Server.keys <$> App.server + if signVerifyDetached (Keys.public sign) publicSignature $ toJSON public + then return $ do + n <- Saltine.decode nonce `orDie` "Could not decode nonce" + decrypted <- secretboxOpen encrypt n private + `orDie` "Could not decrypt private state" + gameOf public <$> eitherDecode' (fromStrict decrypted) + else return $ Left "The game state has been tampered with" + where + orDie :: Maybe a -> String -> Either String a + orDie m errorMessage = maybe (Left errorMessage) Right m + +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 + 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 1fc0b81..0d77871 100644 --- a/src/Messaging.hs +++ b/src/Messaging.hs @@ -24,7 +24,7 @@ import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID) import Hanafuda.Message (FromClient(..), T(..)) import qualified Hanafuda.Message as Message (T) import Network.WebSockets (receiveData, sendTextData) -import qualified Game (export) +import qualified Game (exportGame) import qualified Server (T(..), get) import qualified Session (T(..)) @@ -73,5 +73,5 @@ update = Update {alone = [], paired = []} notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T () notifyPlayers game logs = forM_ (keys $ KoiKoi.scores game) $ \k -> do - state <- Game.export k game + state <- Game.exportGame k game sendTo [k] $ Game {state, logs}