server/src/Game.hs

{-# LANGUAGE NamedFieldPuns #-}
module Game (
      fromPublic
    , new
    , play
    , toPublic
  ) where

import qualified App (T, get)
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, Mode(..), Player, PlayerID, Players)
import qualified Hanafuda.KoiKoi as KoiKoi (
    Action, Game(..), Move(..), play, new
  )
import Hanafuda.Message (
      Coordinates(..), 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(..))

new :: (PlayerID, PlayerID) -> App.T Game
new (for, to) = lift $ KoiKoi.new (for, to) WholeYear

exportPlayers :: Game -> Map PlayerID Player
exportPlayers game =
  let (Player.Players players) = KoiKoi.players game in
  players

getCoordinates :: Game -> Coordinates
getCoordinates game = Coordinates {
      gameID = KoiKoi.gameID game
    , month = KoiKoi.month game
    , turn = 24 - length (KoiKoi.deck game)
  }

privateState :: Coordinates -> Game -> PrivateState
privateState link game = PrivateState {
      link
    , 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 :: Coordinates -> Game -> PublicState
publicState coordinates game = PublicState {
      coordinates
    , mode = KoiKoi.mode game
    , scores = KoiKoi.scores 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
    , rounds = KoiKoi.rounds game
  }

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
      , publicSignature = signDetached (Keys.secret sign) $ toJSON public
    }
  where
    shared = getCoordinates game
    public = publicState shared game
    private = privateState shared game

toJSON :: ToJSON a => a -> ByteString
toJSON = toStrict . encode

merge :: PublicState -> PrivateState -> Game
merge public private = KoiKoi.Game {
        KoiKoi.gameID = gameID $ coordinates public
      , KoiKoi.mode = mode public
      , KoiKoi.scores = scores public
      , KoiKoi.month = month $ coordinates 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 = oyake public
      , KoiKoi.deck = deck private
      , KoiKoi.river = river public
      , KoiKoi.step = step public
      , KoiKoi.trick = trick public
      , KoiKoi.rounds = rounds public
    }

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"
    n <- Saltine.decode nonce `orDie` "Could not decode nonce"
    decrypted <- secretboxOpen encrypt n private
                  `orDie` "Could not decrypt private state"
    decoded <- eitherDecode' (fromStrict decrypted)
    check (link decoded == coordinates public)
      `orDie` "Private and public parts do not match"
    return $ merge public decoded
  where
    orDie :: Maybe a -> String -> Either String a
    orDie m errorMessage = maybe (Left errorMessage) Right m
    check :: Bool -> Maybe ()
    check test = if test then Just () else Nothing

play :: PlayerID -> KoiKoi.Move -> PublicGame -> App.T (Either String (Game, [KoiKoi.Action]))
play playerID move publicGame
  | playing (public publicGame) == playerID = do
      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"