89 lines
3.0 KiB
Haskell
89 lines
3.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
start
|
|
) where
|
|
|
|
import qualified App (Context(..), T, current, debug, get, server, try, update_)
|
|
import Control.Monad.Reader (asks)
|
|
import qualified Game (new, play)
|
|
import qualified Hanafuda.Message as Message (FromClient(..), T(..))
|
|
import qualified Messaging (
|
|
broadcast, get, notifyPlayers, relay, send, sendTo
|
|
)
|
|
import qualified RW (RW(..))
|
|
import qualified Server (logIn, logOut, update, room)
|
|
import qualified Session (Status(..), T(..), Update)
|
|
|
|
receive :: Message.FromClient -> Bool -> App.T ()
|
|
|
|
receive logIn@(Message.LogIn login) False =
|
|
asks App.playerID >>= App.try . (Server.logIn login)
|
|
>>= maybe
|
|
(Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True))
|
|
sendError
|
|
|
|
receive logOut@Message.LogOut True = do
|
|
Messaging.relay logOut Messaging.broadcast
|
|
asks App.playerID >>= App.update_ . Server.logOut
|
|
setSessionStatus (Session.Status False)
|
|
|
|
receive invitation@(Message.Invitation {Message.to}) True = do
|
|
session <- App.get to
|
|
case Session.status session of
|
|
Session.LoggedIn True -> do
|
|
from <- asks App.playerID
|
|
App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update))
|
|
(Messaging.relay invitation $ Messaging.sendTo [to])
|
|
setSessionStatus (Session.Waiting to)
|
|
_ -> sendError "They just left"
|
|
|
|
receive (Session.LoggedIn True) message@(Message.Answer {Message.accept}) = do
|
|
session <- App.get to
|
|
playerID <- asks App.playerID
|
|
case Session.status session of
|
|
Session.Waiting for | for == playerID -> do
|
|
Messaging.relay message $ Messaging.sendTo [to]
|
|
newStatus <-
|
|
if accept
|
|
then do
|
|
game <- Game.new (for, to)
|
|
Messaging.notifyPlayers game []
|
|
return Session.Playing
|
|
else do
|
|
return $ Session.LoggedIn True
|
|
App.update_ $ Server.update to (RW.set newStatus :: Session.Update)
|
|
setSessionStatus newStatus
|
|
_ -> sendError "They're not waiting for your answer"
|
|
|
|
receive Session.Playing (Message.Play {Message.move, Message.onGame}) = do
|
|
playerID <- asks App.playerID
|
|
result <- Game.play playerID move onGame
|
|
case result of
|
|
Left message -> sendError message
|
|
Right (newGame, logs) -> Messaging.notifyPlayers newGame logs
|
|
|
|
receive Session.Playing Message.Quit = setSessionStatus (Session.LoggedIn True)
|
|
|
|
receive state _ = sendError $ "Invalid message in state " ++ show state
|
|
|
|
sendError :: String -> App.T ()
|
|
sendError = Messaging.send . Message.Error
|
|
|
|
setSessionStatus :: Session.Status -> App.T ()
|
|
setSessionStatus newStatus = do
|
|
playerID <- asks App.playerID
|
|
App.update_ $ Server.update playerID $ (RW.set newStatus :: Session.Update)
|
|
App.debug $ show newStatus
|
|
|
|
loop :: App.T ()
|
|
loop = do
|
|
message <- Messaging.get
|
|
receive message (Status.loggedIn . Session.status <$> App.current)
|
|
loop
|
|
|
|
start :: App.T ()
|
|
start = do
|
|
App.debug "Initial state"
|
|
Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send
|
|
loop
|