server/src/Game.hs

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

import qualified App (T, update)
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.Reader (lift)
import Control.Monad.Writer (runWriterT)
import Crypto.Saltine.Core.Sign (signDetached)
import Data.Aeson (encode)
import Data.Map ((!), mapWithKey)
import qualified Hanafuda (empty)
import Hanafuda.KoiKoi (Game, GameID, Mode(..), PlayerID)
import qualified Hanafuda.KoiKoi as KoiKoi (
    Action, Game(..), Move(..), play, new
  )
import Hanafuda.Message (PrivateState(..), PublicGame(..), PublicPlayer(..), PublicState(..))
import qualified Hanafuda.Player (Player(..), Players(..))
import qualified Server (register)

new :: (PlayerID, PlayerID) -> App.T GameID
new (for, to) =
  Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update

extractPrivateState :: PlayerID -> Game -> PrivateState
extractPrivateState playerID game = undefined

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

export :: PlayerID -> Game -> App.T PublicGame
export playerID game = do
  secretKey <- asks $ fst . keypair . mServer
  return $ PublicGame {
        playerHand = hand $ players ! playerID
      , privateState = extractPrivateState playerID game
      , publicState
      , publicSignature = signDetached secretKey publicState
    }
  where
    Hanafuda.Player.Players players = KoiKoi.players game
    publicState = encode $ extractPublicState game

play :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action])
play playerID move game = lift . runWriterT . runExceptT $
  if playing game == playerID
  then KoiKoi.play move game
  else throwError "Not your turn"