server/src/Game.hs

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

import qualified App (T, server, update)
import Control.Monad.Except (runExceptT, throwError)
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 Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Map (Map)
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 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

extractPrivateState :: PlayerID -> Game -> PrivateState
extractPrivateState playerID game = PrivateState {
      opponentHand = getHand opponentID players
    , deck = KoiKoi.deck game
  }
  where
    players = KoiKoi.players game
    opponentID = Player.next players playerID

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
  }

extractPublicState :: Game -> PublicState
extractPublicState game = PublicState {
      mode = KoiKoi.mode game
    , scores = KoiKoi.scores game
    , month = KoiKoi.month 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
  }

export :: PlayerID -> Game -> App.T PublicGame
export 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)
      , privateState = secretbox encrypt n $ toJSON privateState
      , publicState
      , publicSignature = signDetached (secret sign) $ toJSON publicState
    }
  where
    publicState = extractPublicState game
    privateState = extractPrivateState playerID game
    toJSON :: ToJSON a => a -> ByteString
    toJSON = toStrict . encode

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"