Compare commits

...

3 commits

4 changed files with 61 additions and 57 deletions

View file

@ -8,28 +8,27 @@ import Control.Monad.Reader (asks, lift)
import Control.Monad.Writer (runWriterT)
import qualified Data (RW(..))
import qualified Game (new, play)
import qualified Hanafuda.KoiKoi as KoiKoi (Game(..))
import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), players)
import qualified Hanafuda.Player as Player (next)
import qualified Session (Status(..), T(..), Update)
import qualified Server (get, logIn, logOut, update, register)
import qualified Server (endGame, 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
receive :: Session.Status -> Message.FromClient -> App.T ()
edges :: Vertex -> Message.FromClient -> App.T Vertex
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 +36,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
@ -57,42 +56,48 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = 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.On on -> do
App.update_ $ Server.update gameKey (const on)
Message.notifyPlayers on logs
return status
if KoiKoi.on newGame
then do
App.update_ $ Server.update gameKey (const newGame)
Message.notifyPlayers newGame logs
else do
let newStatus = Session.LoggedIn True
let opponent = Player.next (KoiKoi.players newGame) key
App.update_ $ Server.endGame gameKey
App.update_ $ Server.update opponent (Data.set newStatus :: Session.Update)
Message.notifyPlayers newGame logs
move newStatus
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 :: Session.Status -> 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

View file

@ -8,7 +8,6 @@
{-# LANGUAGE OverloadedStrings #-}
module Game (
Key
, View
, T
, export
, new
@ -26,7 +25,7 @@ import qualified Data (Key)
import qualified Player (Key)
import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
import qualified Hanafuda.Player (Player(..), Players(..))
import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), On(..), Over(..), Score, Source(..), Step(..), Yaku(..), new, play)
import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play)
import GHC.Generics
deriving instance Generic Hanafuda.Card
@ -40,13 +39,12 @@ deriving instance Generic Hanafuda.KoiKoi.Step
deriving instance Generic1 (Hanafuda.Player.Player Player.Key)
deriving instance Generic1 (Hanafuda.Player.Players Player.Key)
type On = Hanafuda.KoiKoi.On Player.Key
type Over = Hanafuda.KoiKoi.Over Player.Key
type View = Hanafuda.KoiKoi.Game Player.Key
type T = Hanafuda.KoiKoi.Game Player.Key
deriving instance Generic On
deriving instance Generic Over
deriving instance Generic View
deriving instance Generic T
instance ToJSON T where
toEncoding = genericToEncoding JSON.defaultOptions
instance FromJSON Hanafuda.Card
instance ToJSON Hanafuda.Card
@ -90,29 +88,25 @@ 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 Key = Data.Key T
new :: Player.Key -> Player.Key -> IO T
new p1 p2 = do
Hanafuda.KoiKoi.new [p1, p2] Hanafuda.KoiKoi.WholeYear
Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.FirstAt 1
export :: Player.Key -> T -> Value
export key on = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck on) $ ast
export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast
where
Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players on
Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game
maskOpponentsHand k player
| k == key = player
| otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
Object ast = toJSON $ on {
Object ast = toJSON $ game {
Hanafuda.KoiKoi.players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
}
play :: Hanafuda.KoiKoi.Environment m => Player.Key -> Hanafuda.KoiKoi.Move -> T -> m (Hanafuda.KoiKoi.Game Player.Key)
play key move on
| Hanafuda.KoiKoi.playing on == key =
Hanafuda.KoiKoi.play move on
play key move game
| Hanafuda.KoiKoi.playing game == key =
Hanafuda.KoiKoi.play move game
| otherwise = throwError "Not your turn"

View file

@ -27,7 +27,7 @@ import qualified Game (T, 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(..), Move(..))
import GHC.Generics (Generic)
data FromClient =

View file

@ -8,6 +8,7 @@
module Server (
T(..)
, disconnect
, endGame
, get
, logIn
, logOut
@ -96,6 +97,10 @@ disconnect :: Player.Key -> T -> T
disconnect key =
Data.update (delete key :: Sessions -> Sessions) . logOut key
endGame :: Game.Key -> T -> T
endGame key =
Data.update (delete key :: Games -> Games)
logIn :: Text -> Player.Key -> T -> Either String T
logIn name key server =
Data.update (Set.insert name) .