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 Data.Map (Map, (!?))
import qualified Game (Key, T, new, play)
import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), Step(..))
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 >> setSessionStatus (Session.LoggedIn True))
   sendError

receive (Session.LoggedIn True) logOut@Message.LogOut = do
  Message.relay logOut Message.broadcast
  asks App.key >>= App.update_ . Server.logOut
  setSessionStatus (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])
      setSessionStatus (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)
      setSessionStatus 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 -> do
      Message.notifyPlayers newGame logs
      case KoiKoi.step newGame of
        KoiKoi.Over -> do
          App.debug $ "Game " ++ show gameKey ++ " ended"
          App.update_ $ Server.endGame gameKey
        _ -> App.update_ $ Server.update gameKey (const newGame)

receive (Session.Playing gameKey) Message.Quit = do
  games <- (Data.get <$> App.server :: App.T (Map Game.Key Game.T))
  case games !? gameKey of
    Nothing -> do
      key <- asks App.key
      Message.broadcast $ Message.update {Message.alone = [key]}
      setSessionStatus (Session.LoggedIn True)
    _ -> sendError "Game is still running"

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

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

setSessionStatus :: Session.Status -> App.T ()
setSessionStatus 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