94 lines
3.3 KiB
Haskell
94 lines
3.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
start
|
|
) where
|
|
|
|
import Control.Monad.Reader (asks, lift)
|
|
import qualified Data (RW(..))
|
|
import qualified Game (Game(..), T(..), new, play)
|
|
import qualified Session (Status(..), T(..), Update)
|
|
import qualified Server (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)
|
|
|
|
type Vertex = Session.Status
|
|
|
|
edges :: Vertex -> Message.FromClient -> App.T Vertex
|
|
|
|
edges (Session.LoggedIn False) logIn@(Message.LogIn login) =
|
|
asks App.key >>= App.try . (Server.logIn login)
|
|
>>= maybe
|
|
(Message.relay logIn Message.broadcast >> return (Session.LoggedIn True))
|
|
(withError $ Session.LoggedIn False)
|
|
|
|
edges (Session.LoggedIn True) logOut@Message.LogOut = do
|
|
Message.relay logOut Message.broadcast
|
|
asks App.key >>= App.update_ . Server.logOut
|
|
return (Session.LoggedIn False)
|
|
|
|
edges (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])
|
|
return (Session.Waiting to)
|
|
_ -> Session.LoggedIn True `withError` "They just left"
|
|
|
|
edges (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)
|
|
return newStatus
|
|
_ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
|
|
|
|
edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do
|
|
key <- asks App.key
|
|
game <- Server.get gameKey <$> App.server
|
|
newGame <- lift $ Game.play key move game
|
|
case Game.state newGame of
|
|
Game.Error s -> status `withError` s
|
|
Game.Over _ -> undefined
|
|
Game.On _ -> do
|
|
App.update_ $ Server.update gameKey (const newGame)
|
|
Message.notifyPlayers newGame
|
|
return status
|
|
|
|
edges state _ =
|
|
state `withError` ("Invalid message in state " ++ show state)
|
|
|
|
withError :: Vertex -> String -> App.T Vertex
|
|
withError vertex message =
|
|
(Message.send $ Message.Error message) >> return vertex
|
|
|
|
run :: App.T ()
|
|
run = do
|
|
message <- Message.get
|
|
status <- Session.status <$> App.current
|
|
newStatus <- edges status message
|
|
key <- asks App.key
|
|
App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
|
|
App.debug $ show newStatus
|
|
run
|
|
|
|
start :: App.T ()
|
|
start = do
|
|
App.debug "Initial state"
|
|
Message.Welcome <$> App.server <*> asks App.key >>= Message.send
|
|
run
|