79 lines
2.6 KiB
Haskell
79 lines
2.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
loop
|
|
) where
|
|
|
|
import qualified App (Context(..), T, exec, get, player, 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 Player (T(..))
|
|
import qualified Server (logIn, register, room, update)
|
|
import qualified Session (Status, T(..), setPlayer)
|
|
|
|
receive :: Message.FromClient -> Session.Status -> App.T ()
|
|
|
|
receive (Message.Hello {Message.name}) Nothing = do
|
|
sessionID <- asks App.sessionID
|
|
playerID <- App.exec (Server.register [sessionID])
|
|
room <- App.get Server.room
|
|
Messaging.send $ Message.Welcome room playerID
|
|
App.update (Server.update sessionID $ Session.setPlayer playerID name)
|
|
Messaging.broadcast $ Message.LogIn playerID name
|
|
|
|
receive (Message.Hello {Message.name}) (Just player) = do
|
|
sessionID <- asks App.sessionID
|
|
App.update (Server.update sessionID setName)
|
|
where
|
|
setName session = session {Session.player = Just $ player {Player.name}}
|
|
|
|
receive (Message.Tadaima {Message.myID, Message.name}) Nothing = do
|
|
sessionID <- asks App.sessionID
|
|
Message.Okaeri <$> App.get Server.room >>= Messaging.send
|
|
App.update $ Server.logIn name myID sessionID
|
|
Messaging.broadcast $ Message.LogIn myID name
|
|
|
|
receive (Message.Tadaima {}) (Just _) = sendError "You're already logged in"
|
|
|
|
{-
|
|
receive logOut@Message.LogOut (Just _) = do
|
|
asks App.sessionID >>= App.update . Server.logOut
|
|
Messaging.relay logOut Messaging.broadcast
|
|
-}
|
|
|
|
receive invitation@(Message.Invitation {Message.to}) (Just _) =
|
|
Messaging.relay invitation (Messaging.sendTo [to])
|
|
|
|
receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) =
|
|
if accept
|
|
then do
|
|
game <- Game.new (Player.playerID player, to)
|
|
Messaging.notifyPlayers game []
|
|
else Messaging.relay answer (Messaging.sendTo [to])
|
|
|
|
receive (Message.Play {Message.move, Message.onGame}) (Just player) = do
|
|
result <- Game.play (Player.playerID player) move onGame
|
|
case result of
|
|
Left message -> sendError message
|
|
Right (newGame, logs) -> Messaging.notifyPlayers newGame logs
|
|
|
|
receive message state =
|
|
sendError $ "Invalid message " ++ show message ++ " in " ++ showState
|
|
where
|
|
showState =
|
|
case state of
|
|
Nothing -> "disconnected state"
|
|
Just _ -> "connected state"
|
|
|
|
sendError :: String -> App.T ()
|
|
sendError = Messaging.send . Message.Error
|
|
|
|
loop :: App.T ()
|
|
loop = do
|
|
message <- Messaging.get
|
|
receive message =<< App.player
|
|
loop
|