server/src/Automaton.hs

{-# LANGUAGE NamedFieldPuns #-}
module Automaton (
    start
  ) where

import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (asks, lift)
import Control.Monad.Writer (runWriterT)
import qualified Data (RW(..))
import qualified Game (new, play)
import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), players)
import qualified Hanafuda.Player as Player (next)
import qualified Session (Status(..), T(..), Update)
import qualified Server (endGame, get, logIn, logOut, update, register)
import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, update)

receive :: Session.Status -> Message.FromClient -> App.T ()

receive (Session.LoggedIn False) logIn@(Message.LogIn login) =
  asks App.key >>= App.try . (Server.logIn login)
  >>= maybe
   (Message.relay logIn Message.broadcast >> move (Session.LoggedIn True))
   sendError

receive (Session.LoggedIn True) logOut@Message.LogOut = do
  Message.relay logOut Message.broadcast
  asks App.key >>= App.update_ . Server.logOut
  move (Session.LoggedIn False)

receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
  session <- App.get to
  case Session.status session of
    Session.LoggedIn True -> do
      key <- asks App.key
      App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update))
      Message.broadcast $ Message.update {Message.paired = [key, to]}
      (Message.relay invitation $ Message.sendTo [to])
      move (Session.Waiting to)
    _ -> sendError "They just left"

receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
  session <- App.get to
  key <- asks App.key
  case Session.status session of
    Session.Waiting for | for == key -> do
      Message.relay message $ Message.sendTo [to]
      newStatus <-
        if accept
          then do
            gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
            game <- Server.get gameKey <$> App.server
            Message.notifyPlayers game []
            return $ Session.Playing gameKey
          else do
            Message.broadcast $ Message.update {Message.alone = [key, to]}
            return $ Session.LoggedIn True
      App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
      move newStatus
    _ -> sendError "They're not waiting for your answer"

receive (Session.Playing gameKey) played@(Message.Play {}) = do
  key <- asks App.key
  game <- Server.get gameKey <$> App.server
  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game
  case result of
    Left message -> sendError message
    Right newGame ->
      if KoiKoi.on newGame
        then do
          App.update_ $ Server.update gameKey (const newGame)
          Message.notifyPlayers newGame logs
        else do
          let newStatus = Session.LoggedIn True
          let opponent = Player.next (KoiKoi.players newGame) key
          App.update_ $ Server.endGame gameKey
          App.update_ $ Server.update opponent (Data.set newStatus :: Session.Update)
          Message.notifyPlayers newGame logs
          move newStatus

receive state _ = sendError $ "Invalid message in state " ++ show state

sendError :: String -> App.T ()
sendError = Message.send . Message.Error

move :: Session.Status -> App.T ()
move newStatus = do
  key <- asks App.key
  App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
  App.debug $ show newStatus

loop :: App.T ()
loop = do
  message <- Message.get
  status <- Session.status <$> App.current
  status `receive` message
  loop

start :: App.T ()
start = do
  App.debug "Initial state"
  Message.Welcome <$> App.server <*> asks App.key >>= Message.send
  loop