diff --git a/src/Automaton.hs b/src/Automaton.hs index 85c7404..0cfcea6 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -16,20 +16,20 @@ import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, type Vertex = Session.Status -edges :: Vertex -> Message.FromClient -> App.T Vertex +receive :: Vertex -> Message.FromClient -> App.T () -edges (Session.LoggedIn False) logIn@(Message.LogIn login) = +receive (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) + (Message.relay logIn Message.broadcast >> move (Session.LoggedIn True)) + sendError -edges (Session.LoggedIn True) logOut@Message.LogOut = do +receive (Session.LoggedIn True) logOut@Message.LogOut = do Message.relay logOut Message.broadcast asks App.key >>= App.update_ . Server.logOut - return (Session.LoggedIn False) + move (Session.LoggedIn False) -edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do +receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do session <- App.get to case Session.status session of Session.LoggedIn True -> do @@ -37,10 +37,10 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do 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" + move (Session.Waiting to) + _ -> sendError "They just left" -edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do +receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do session <- App.get to key <- asks App.key case Session.status session of @@ -51,48 +51,49 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do then do gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update game <- Server.get gameKey <$> App.server - Message.notifyPlayers game [] + Message.notifyPlayers (KoiKoi.On 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" + move newStatus + _ -> sendError "They're not waiting for your answer" -edges status@(Session.Playing gameKey) (Message.Play {Message.move}) = do +receive (Session.Playing gameKey) played@(Message.Play {}) = do key <- asks App.key game <- Server.get gameKey <$> App.server - (result, logs) <- lift . runWriterT . runExceptT $ Game.play key move game + (result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game case result of - Left message -> status `withError` message + Left message -> sendError message Right newGame -> case newGame of - KoiKoi.Over _ -> undefined + KoiKoi.Over _ -> + Message.notifyPlayers newGame logs KoiKoi.On on -> do App.update_ $ Server.update gameKey (const on) - Message.notifyPlayers on logs - return status + Message.notifyPlayers newGame logs -edges state _ = - state `withError` ("Invalid message in state " ++ show state) +receive state _ = sendError $ "Invalid message in state " ++ show state -withError :: Vertex -> String -> App.T Vertex -withError vertex message = - (Message.send $ Message.Error message) >> return vertex +sendError :: String -> App.T () +sendError = Message.send . Message.Error -run :: App.T () -run = do - message <- Message.get - status <- Session.status <$> App.current - newStatus <- edges status message +move :: Vertex -> App.T () +move newStatus = do key <- asks App.key App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update) App.debug $ show newStatus - run + +loop :: App.T () +loop = do + message <- Message.get + status <- Session.status <$> App.current + status `receive` message + loop start :: App.T () start = do App.debug "Initial state" Message.Welcome <$> App.server <*> asks App.key >>= Message.send - run + loop diff --git a/src/Game.hs b/src/Game.hs index 2678d59..db8f21d 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -48,6 +48,11 @@ deriving instance Generic On deriving instance Generic Over deriving instance Generic View +instance ToJSON On where + toEncoding = genericToEncoding JSON.defaultOptions +instance ToJSON Over where + toEncoding = genericToEncoding JSON.defaultOptions + instance FromJSON Hanafuda.Card instance ToJSON Hanafuda.Card @@ -90,9 +95,7 @@ instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where toJSON = toJSON1 toEncoding = toEncoding1 -type T = Hanafuda.KoiKoi.On Player.Key - -instance ToJSON T +type T = On type Key = Data.Key T @@ -100,8 +103,9 @@ new :: Player.Key -> Player.Key -> IO T new p1 p2 = do Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear -export :: Player.Key -> T -> Value -export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast +export :: Player.Key -> View -> Value +export _ (Hanafuda.KoiKoi.Over over) = toJSON over +export key (Hanafuda.KoiKoi.On on) = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast where Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on maskOpponentsHand k player diff --git a/src/Message.hs b/src/Message.hs index 12e1f05..3938b73 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -23,11 +23,11 @@ import Data.ByteString.Lazy.Char8 (unpack) import Data.Text (Text) import Control.Monad.Reader (asks, lift) import qualified Player (Key) -import qualified Game (T, export) +import qualified Game (View, export) import qualified Session (T(..)) import qualified Server (T(..), get) import qualified App (Context(..), T, connection, debug, server) -import qualified Hanafuda.KoiKoi as KoiKoi (Action, On(..), Move(..)) +import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), On(..), Over(..), Move(..)) import GHC.Generics (Generic) data FromClient = @@ -98,7 +98,10 @@ get = update :: T update = Update {alone = [], paired = []} -notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T () -notifyPlayers game logs = - forM_ (keys $ KoiKoi.scores game) $ \k -> +notifyPlayers :: Game.View -> [KoiKoi.Action] -> App.T () +notifyPlayers game@(KoiKoi.Over over) logs = + forM_ (keys $ KoiKoi.finalScores over) $ \k -> + sendTo [k] $ Game {game = Game.export k game, logs} +notifyPlayers game@(KoiKoi.On on) logs = + forM_ (keys $ KoiKoi.scores on) $ \k -> sendTo [k] $ Game {game = Game.export k game, logs}