69 lines
2.4 KiB
Haskell
69 lines
2.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
start
|
|
) where
|
|
|
|
import Control.Monad.Reader (asks)
|
|
import qualified Player (Session(..), Status(..))
|
|
import qualified Server (logIn, logOut, setStatus)
|
|
import qualified Session (App, T(..), current, debug, get, server, try, update)
|
|
import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo)
|
|
|
|
type Vertex = Player.Status
|
|
|
|
edges :: Vertex -> Message.FromClient -> Session.App Vertex
|
|
|
|
edges (Player.LoggedIn False) logIn@(Message.LogIn login) =
|
|
asks Session.key >>= Session.try . (Server.logIn login)
|
|
>>= maybe
|
|
(Message.relay logIn Message.broadcast >> return (Player.LoggedIn True))
|
|
(withError $ Player.LoggedIn False)
|
|
|
|
edges (Player.LoggedIn True) logOut@Message.LogOut = do
|
|
Message.relay logOut Message.broadcast
|
|
asks Session.key >>= Session.update . Server.logOut
|
|
return (Player.LoggedIn False)
|
|
|
|
edges (Player.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
|
|
session <- Session.get to
|
|
case Player.status session of
|
|
Player.LoggedIn True -> do
|
|
key <- asks Session.key
|
|
Session.update (Server.setStatus (Player.Answering key) to)
|
|
(Message.relay invitation $ Message.sendTo (to, session))
|
|
return (Player.Waiting to)
|
|
_ -> Player.LoggedIn True `withError` "They just left"
|
|
|
|
edges (Player.Answering to) message@(Message.Answer {Message.accept}) = do
|
|
session <- Session.get to
|
|
key <- asks Session.key
|
|
case Player.status session of
|
|
Player.Waiting for | for == key -> do
|
|
Message.relay message $ Message.sendTo (to, session)
|
|
if accept
|
|
then Session.debug "Yeah ! Let's start a game" >> return (Player.LoggedIn True)
|
|
else Session.debug "Oh, they said no" >> return (Player.LoggedIn True)
|
|
_ -> (Player.LoggedIn True) `withError` "They're not waiting for your answer"
|
|
|
|
edges state _ =
|
|
state `withError` ("Invalid message in state " ++ show state)
|
|
|
|
withError :: Vertex -> String -> Session.App Vertex
|
|
withError vertex message =
|
|
(Message.send $ Message.Error message) >> return vertex
|
|
|
|
run :: Session.App ()
|
|
run = do
|
|
message <- Message.get
|
|
status <- Player.status <$> Session.current
|
|
newStatus <- edges status message
|
|
Server.setStatus newStatus <$> asks Session.key >>= Session.update
|
|
Session.debug $ show newStatus
|
|
run
|
|
|
|
start :: Session.App ()
|
|
start = do
|
|
Session.debug "Initial state"
|
|
Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send
|
|
run
|