92 lines
3.2 KiB
Haskell
92 lines
3.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Automaton (
|
|
loop
|
|
) where
|
|
|
|
import qualified App (Context(..), T, exec, get, player, update)
|
|
import Control.Monad.Reader (asks)
|
|
import Data.Map ((!))
|
|
import qualified Game (fromPublic, new, play, toPublic)
|
|
import qualified Hanafuda.KoiKoi as KoiKoi (Game(..))
|
|
import qualified Hanafuda.Message as Message (
|
|
FromClient(..), PublicGame(..), T(..)
|
|
)
|
|
import qualified Messaging (
|
|
broadcast, get, notifyPlayers, relay, send, sendTo
|
|
)
|
|
import qualified Player (T(..))
|
|
import qualified Server (T(..), 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
|
|
sessionIDs <- (! playerID) <$> App.get Server.sessionIDsByPlayerID
|
|
App.update (\server -> foldr (flip Server.update setName) server sessionIDs)
|
|
Messaging.broadcast $ Message.LogIn playerID name
|
|
where
|
|
playerID = Player.playerID player
|
|
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 invitation@(Message.Invitation {}) (Just _) = relay invitation
|
|
|
|
receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) =
|
|
if accept
|
|
then do
|
|
publicGames <- Game.new (Player.playerID player, to)
|
|
Messaging.relay answer (Messaging.sendTo [to])
|
|
Messaging.notifyPlayers (publicGames, [])
|
|
else Messaging.relay answer (Messaging.sendTo [to])
|
|
|
|
receive (Message.Play {Message.move, Message.onGame}) (Just player) =
|
|
Game.play (Player.playerID player) move onGame
|
|
>>= either sendError Messaging.notifyPlayers
|
|
|
|
receive sync@(Message.Sync {}) (Just _) = relay sync
|
|
receive yield@(Message.Yield {}) (Just _) = relay yield
|
|
|
|
receive (Message.Share {Message.gameSave}) (Just player) =
|
|
either sendError share =<< Game.fromPublic gameSave
|
|
where
|
|
logs = Message.logs gameSave
|
|
share game =
|
|
let recipientID = KoiKoi.nextPlayer game ! (Player.playerID player) in
|
|
Game.toPublic recipientID game logs
|
|
>>= Messaging.sendTo [recipientID] . Message.Game
|
|
|
|
receive message state =
|
|
sendError $ "Invalid message " ++ show message ++ " in " ++ showState
|
|
where
|
|
showState =
|
|
case state of
|
|
Nothing -> "disconnected state"
|
|
Just _ -> "connected state"
|
|
|
|
relay :: Message.FromClient -> App.T ()
|
|
relay message = Messaging.relay message (Messaging.sendTo [Message.to message])
|
|
|
|
sendError :: String -> App.T ()
|
|
sendError = Messaging.send . Message.Error
|
|
|
|
loop :: App.T ()
|
|
loop = do
|
|
message <- Messaging.get
|
|
receive message =<< App.player
|
|
loop
|