138 lines
4.8 KiB
Haskell
138 lines
4.8 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Game (
|
|
exportGame
|
|
, new
|
|
, play
|
|
) where
|
|
|
|
import qualified App (T, server, update)
|
|
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, secretboxOpen)
|
|
import Crypto.Saltine.Core.Sign (signDetached, signVerifyDetached)
|
|
import Data.Aeson (ToJSON, eitherDecode', encode)
|
|
import Data.ByteString (ByteString)
|
|
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)
|
|
import Keys (T(..))
|
|
import qualified Keys (public, secret)
|
|
import qualified Server (T(..), register)
|
|
|
|
new :: (PlayerID, PlayerID) -> App.T GameID
|
|
new (for, to) =
|
|
Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update
|
|
|
|
exportPlayers :: Game -> Map PlayerID Player
|
|
exportPlayers game =
|
|
let (Player.Players players) = KoiKoi.players game in
|
|
players
|
|
|
|
privateState :: Game -> PrivateState
|
|
privateState game = PrivateState {
|
|
hands = Player.hand <$> players
|
|
, deck = KoiKoi.deck game
|
|
}
|
|
where
|
|
Player.Players players = KoiKoi.players game
|
|
|
|
getHand :: PlayerID -> Players -> Hanafuda.Pack
|
|
getHand playerID = Player.hand . (Player.get playerID)
|
|
|
|
publicPlayer :: Player -> PublicPlayer
|
|
publicPlayer player = PublicPlayer {
|
|
meld = Player.meld player
|
|
, 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
|
|
, oyake = KoiKoi.oyake game
|
|
, river = KoiKoi.river game
|
|
, step = KoiKoi.step game
|
|
, trick = KoiKoi.trick game
|
|
, turns = 24 - length (KoiKoi.deck game)
|
|
, rounds = KoiKoi.rounds game
|
|
}
|
|
|
|
exportGame :: PlayerID -> Game -> App.T PublicGame
|
|
exportGame playerID game = do
|
|
Keys.T {encrypt, sign} <- Server.keys <$> App.server
|
|
n <- lift newNonce
|
|
return $ PublicGame {
|
|
nonce = Saltine.encode n
|
|
, playerHand = getHand playerID (KoiKoi.players game)
|
|
, private = secretbox encrypt n $ toJSON private
|
|
, public
|
|
, publicSignature = signDetached (Keys.secret sign) $ toJSON public
|
|
}
|
|
where
|
|
public = publicState game
|
|
private = privateState game
|
|
|
|
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"
|