hanafuda
/
server
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Follow renaming (Key -> ID) in hanafuda lib, finish taking IDs declaration out of the webapp and simplify Automaton by putting some operations back into Game module

This commit is contained in:
Tissevert 2019-08-24 22:17:52 +02:00
parent 539b74990e
commit 3e7c0a88f1
8 changed files with 110 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/App.hs
View File

@ -16,13 +16,13 @@ import Data.Map ((!))
import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Network.WebSockets (Connection)
import Hanafuda.KoiKoi (PlayerKey)
import Hanafuda.KoiKoi (PlayerID)
import qualified Session (T(..))
import qualified Server (T(..))
data Context = Context {
mServer :: MVar Server.T
, key :: PlayerKey
, playerID :: PlayerID
}
type T a = ReaderT Context IO a
@ -30,20 +30,20 @@ type T a = ReaderT Context IO a
server :: T Server.T
server = asks mServer >>= lift . readMVar
get :: PlayerKey -> T Session.T
get key =
(! key) . Server.sessions <$> server
get :: PlayerID -> T Session.T
get playerID =
(! playerID) . Server.sessions <$> server
current :: T Session.T
current = do
asks key >>= get
asks playerID >>= get
connection :: T Connection
connection = Session.connection <$> current
debug :: String -> T ()
debug message =
show <$> asks key
show <$> asks playerID
>>= lift . putStrLn . (++ ' ':message)
try :: (Server.T -> Either String Server.T) -> T (Maybe String)

70
src/Automaton.hs
View File

@ -3,83 +3,85 @@ module Automaton (
start
) where
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (asks, lift)
import Control.Monad.Writer (runWriterT)
import Control.Monad.Reader (asks)
import qualified Data (RW(..))
import Data.Map (Map, (!?))
import qualified Game (Key, T, new, play)
import qualified Hanafuda.KoiKoi as KoiKoi (GameBlueprint(..), Step(..))
import qualified Game (new, play)
import qualified Hanafuda.KoiKoi as KoiKoi (
Game, GameBlueprint(..), GameID, Step(..)
)
import qualified Session (Status(..), T(..), Update)
import qualified Server (endGame, get, logIn, logOut, update, register, room)
import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
import qualified Server (endGame, get, logIn, logOut, update, room)
import qualified App (Context(..), T, current, debug, get, server, try, update_)
import qualified Hanafuda.Message as Message (FromClient(..), T(..))
import qualified Messaging (broadcast, get, notifyPlayers, relay, send, sendTo, update)
import qualified Messaging (
broadcast, get, notifyPlayers, relay, send, sendTo, update
)
receive :: Session.Status -> Message.FromClient -> App.T ()
receive (Session.LoggedIn False) logIn@(Message.LogIn login) =
asks App.key >>= App.try . (Server.logIn login)
asks App.playerID >>= App.try . (Server.logIn login)
>>= maybe
(Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True))
sendError
receive (Session.LoggedIn True) logOut@Message.LogOut = do
Messaging.relay logOut Messaging.broadcast
asks App.key >>= App.update_ . Server.logOut
asks App.playerID >>= App.update_ . Server.logOut
setSessionStatus (Session.LoggedIn False)
receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
session <- App.get to
case Session.status session of
Session.LoggedIn True -> do
key <- asks App.key
App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update))
Messaging.broadcast $ Messaging.update {Message.paired = [key, to]}
from <- asks App.playerID
App.update_ (Server.update to (Data.set $ Session.Answering from :: Session.Update))
Messaging.broadcast $ Messaging.update {Message.paired = [from, to]}
(Messaging.relay invitation $ Messaging.sendTo [to])
setSessionStatus (Session.Waiting to)
_ -> sendError "They just left"
receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
session <- App.get to
key <- asks App.key
playerID <- asks App.playerID
case Session.status session of
Session.Waiting for | for == key -> do
Session.Waiting for | for == playerID -> do
Messaging.relay message $ Messaging.sendTo [to]
newStatus <-
if accept
then do
gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
game <- Server.get gameKey <$> App.server
gameID <- Game.new (for, to)
game <- Server.get gameID <$> App.server
Messaging.notifyPlayers game []
return $ Session.Playing gameKey
return $ Session.Playing gameID
else do
Messaging.broadcast $ Messaging.update {Message.alone = [key, to]}
Messaging.broadcast $ Messaging.update {Message.alone = [for, to]}
return $ Session.LoggedIn True
App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
setSessionStatus newStatus
_ -> sendError "They're not waiting for your answer"
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 (Message.move played) game
receive (Session.Playing gameID) played@(Message.Play {}) = do
playerID <- asks App.playerID
game <- Server.get gameID <$> App.server
(result, logs) <- Game.play playerID (Message.move played) game
case result of
Left message -> sendError message
Right newGame -> do
case KoiKoi.step newGame of
KoiKoi.Over -> do
App.debug $ "Game " ++ show gameKey ++ " ended"
App.update_ $ Server.endGame gameKey
_ -> App.update_ $ Server.update gameKey (const newGame)
App.debug $ "Game " ++ show gameID ++ " ended"
App.update_ $ Server.endGame gameID
_ -> App.update_ $ Server.update gameID (const newGame)
Messaging.notifyPlayers newGame logs
receive (Session.Playing gameKey) Message.Quit = do
games <- (Data.get <$> App.server :: App.T (Map Game.Key Game.T))
case games !? gameKey of
receive (Session.Playing gameID) Message.Quit = do
games <- (Data.get <$> App.server :: App.T (Map KoiKoi.GameID KoiKoi.Game))
case games !? gameID of
Nothing -> do
key <- asks App.key
Messaging.broadcast $ Messaging.update {Message.alone = [key]}
playerID <- asks App.playerID
Messaging.broadcast $ Messaging.update {Message.alone = [playerID]}
setSessionStatus (Session.LoggedIn True)
_ -> sendError "Game is still running"
@ -90,8 +92,8 @@ sendError = Messaging.send . Message.Error
setSessionStatus :: Session.Status -> App.T ()
setSessionStatus newStatus = do
key <- asks App.key
App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
playerID <- asks App.playerID
App.update_ $ Server.update playerID $ (Data.set newStatus :: Session.Update)
App.debug $ show newStatus
loop :: App.T ()
@ -104,5 +106,5 @@ loop = do
start :: App.T ()
start = do
App.debug "Initial state"
Message.Welcome . Server.room <$> App.server <*> asks App.key >>= Messaging.send
Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send
loop

21
src/Data.hs
View File

@ -1,30 +1,11 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
module Data (
Key(..)
, RW(..)
RW(..)
) where
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSONKey(..), genericToEncoding)
import Data.Aeson.Types (toJSONKeyText)
import Data.Text (pack)
import GHC.Generics
import qualified JSON (defaultOptions)
class RW a b where
get :: b -> a
set :: a -> b -> b
update :: (a -> a) -> b -> b
update f v =
set (f (get v)) v
newtype Key a = Key Int deriving (Eq, Ord, Enum, Read, Show, Generic)
instance FromJSON (Key a)
instance ToJSON (Key a) where
toEncoding = genericToEncoding JSON.defaultOptions
instance ToJSONKey (Key a) where
toJSONKey = toJSONKeyText (pack . \(Key n) -> show n)

51
src/Game.hs
View File

@ -1,49 +1,40 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Game (
Key
, T
, export
export
, new
, play
) where
import Control.Monad.Except (throwError)
import qualified App (T, update)
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.Reader (lift)
import Control.Monad.Writer (runWriterT)
import Data.Map (mapWithKey)
import qualified Data (Key)
import qualified Hanafuda (empty)
import qualified Hanafuda.KoiKoi (Game, Environment, Mode(..), Move(..), PlayerKey, new, play)
import Hanafuda.KoiKoi (GameBlueprint(..))
import qualified Hanafuda.KoiKoi as KoiKoi (
Action, Move(..), play, new
)
import Hanafuda.KoiKoi (Game, GameBlueprint(..), GameID, Mode(..), PlayerID)
import qualified Hanafuda.Player (Player(..), Players(..))
import Hanafuda.Message (PublicGame)
import qualified Server (register)
new :: (PlayerID, PlayerID) -> App.T GameID
new (for, to) =
Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update
type T = Hanafuda.KoiKoi.Game
type Key = Data.Key T
new :: Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.PlayerKey -> IO T
new p1 p2 = do
Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.WholeYear
export :: Hanafuda.KoiKoi.PlayerKey -> T -> PublicGame
export key game = game {
export :: PlayerID -> Game -> PublicGame
export playerID game = game {
deck = length $ deck game
, players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
}
where
Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game
maskOpponentsHand k player
| k == key = player
| k == playerID = player
| otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
play :: Hanafuda.KoiKoi.Environment m => Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.Move -> T -> m T
play key move game
| Hanafuda.KoiKoi.playing game == key =
Hanafuda.KoiKoi.play move game
| otherwise = throwError "Not your turn"
play :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action])
play playerID move game = lift . runWriterT . runExceptT $
if playing game == playerID
then KoiKoi.play move game
else throwError "Not your turn"

6
src/Main.hs
View File

@ -20,7 +20,7 @@ import qualified Automaton (start)
exit :: App.T ()
exit = do
asks App.key >>= App.update_ . Server.disconnect
asks App.playerID >>= App.update_ . Server.disconnect
relay Message.LogOut broadcast
serverApp :: App.T () -> App.T () -> IO ServerApp
@ -28,8 +28,8 @@ serverApp onEnter onExit = do
mServer <- newMVar Server.new
return $ \pending -> do
session <- Session.open <$> acceptRequest pending
key <- modifyMVar mServer (return . Server.register session)
let app = App.Context {App.mServer, App.key}
playerID <- modifyMVar mServer (return . Server.register session)
let app = App.Context {App.mServer, App.playerID}
finally
(runReaderT onEnter app)
(runReaderT onExit app)

20
src/Messaging.hs
View File

@ -20,28 +20,28 @@ import Data.Aeson (eitherDecode', encode)
import Network.WebSockets (receiveData, sendTextData)
import Data.ByteString.Lazy.Char8 (unpack)
import Control.Monad.Reader (asks, lift)
import qualified Game (T, export)
import qualified Game (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, GameBlueprint(..), PlayerKey)
import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game, GameBlueprint(..), PlayerID)
import qualified Hanafuda.Message as Message (T)
import Hanafuda.Message (FromClient(..), T(..))
sendTo :: [KoiKoi.PlayerKey] -> Message.T -> App.T ()
sendTo playerKeys obj = do
sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T ()
sendTo playerIDs obj = do
sessions <- getSessions <$> App.server
App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded
where
encoded = encode $ obj
getSessions server = (\key -> Server.get key server) <$> playerKeys
recipients = show <$> playerKeys
getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs
recipients = show <$> playerIDs
send :: Message.T -> App.T ()
send obj = do
key <- asks App.key
sendTo [key] obj
playerID <- asks App.playerID
sendTo [playerID] obj
broadcast :: Message.T -> App.T ()
broadcast obj =
@ -50,7 +50,7 @@ broadcast obj =
relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
relay message f = do
App.debug "Relaying"
(\from -> f $ Relay {from, message}) =<< asks App.key
(\from -> f $ Relay {from, message}) =<< asks App.playerID
receive :: App.T FromClient
receive = do
@ -70,7 +70,7 @@ get =
update :: T
update = Update {alone = [], paired = []}
notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T ()
notifyPlayers game logs =
forM_ (keys $ KoiKoi.scores game) $ \k ->
sendTo [k] $ Game {game = Game.export k game, logs}

63
src/Server.hs
View File

@ -2,9 +2,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Server (
T(..)
, disconnect
@ -23,17 +21,16 @@ import qualified Data.Map as Map (empty)
import Data.Set (Set, member)
import qualified Data.Set as Set (delete, empty, insert)
import Data.Text (Text)
import Hanafuda.KoiKoi (PlayerKey)
import Hanafuda.KoiKoi (Game, GameID, PlayerID)
import Hanafuda.Message (PlayerStatus(..), Room)
import qualified Data (RW(..))
import qualified Game (Key, T)
import qualified Player (T(..))
import qualified Session (Status(..), T(..), Update)
type Names = Set Text
type Players = Map PlayerKey Player.T
type Sessions = Map PlayerKey Session.T
type Games = Map Game.Key Game.T
type Players = Map PlayerID Player.T
type Sessions = Map PlayerID Session.T
type Games = Map GameID Game
data T = T {
names :: Names
, players :: Players
@ -57,23 +54,17 @@ instance Data.RW Games T where
get = games
set games server = server {games}
export :: Sessions -> PlayerKey -> Player.T -> PlayerStatus
export sessions key player = PlayerStatus (Player.name player, alone)
export :: Sessions -> PlayerID -> Player.T -> PlayerStatus
export sessions playerID player = PlayerStatus (Player.name player, alone)
where
alone =
case Session.status (sessions ! key) of
case Session.status (sessions ! playerID) of
Session.LoggedIn True -> True
_ -> False
room :: T -> Room
room (T {players, sessions}) = mapWithKey (export sessions) players
{-
instance ToJSON T where
toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players
-}
new :: T
new = T {
names = Set.empty
@ -84,39 +75,39 @@ new = T {
register :: forall a b. (Enum a, Ord a, Data.RW (Map a b) T) => b -> T -> (T, a)
register x server =
let key = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
(Data.update (insert key x) server, key)
let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
(Data.update (insert playerID x) server, playerID)
get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
get key server = (Data.get server :: Map a b) ! key
get playerID server = (Data.get server :: Map a b) ! playerID
update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T
update key updator =
Data.update (adjust updator key :: Map a b -> Map a b)
update playerID updator =
Data.update (adjust updator playerID :: Map a b -> Map a b)
disconnect :: PlayerKey -> T -> T
disconnect key =
Data.update (delete key :: Sessions -> Sessions) . logOut key
disconnect :: PlayerID -> T -> T
disconnect playerID =
Data.update (delete playerID :: Sessions -> Sessions) . logOut playerID
endGame :: Game.Key -> T -> T
endGame key =
Data.update (delete key :: Games -> Games)
endGame :: GameID -> T -> T
endGame playerID =
Data.update (delete playerID :: Games -> Games)
logIn :: Text -> PlayerKey -> T -> Either String T
logIn name key server =
logIn :: Text -> PlayerID -> T -> Either String T
logIn name playerID server =
Data.update (Set.insert name) .
Data.update (insert key $ Player.T {Player.name}) .
update key (Data.set $ Session.LoggedIn True :: Session.Update) <$>
Data.update (insert playerID $ Player.T {Player.name}) .
update playerID (Data.set $ Session.LoggedIn True :: Session.Update) <$>
if name `member` names server
then Left "This name is already registered"
else Right server
logOut :: PlayerKey -> T -> T
logOut key server =
logOut :: PlayerID -> T -> T
logOut playerID server =
maybe
server
(\player ->
Data.update (delete key :: Players -> Players) $
update key (Data.set $ Session.LoggedIn False :: Session.Update) $
Data.update (delete playerID :: Players -> Players) $
update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $
Data.update (Set.delete $ Player.name player :: Names -> Names) server)
(players server !? key)
(players server !? playerID)

18
src/Session.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
module Session (
Status(..)
, T(..)
@ -9,22 +8,15 @@ module Session (
) where
import Network.WebSockets (Connection)
import Data.Aeson (ToJSON(..), genericToEncoding)
import GHC.Generics (Generic)
import Hanafuda.KoiKoi (PlayerKey)
import qualified JSON (singleLCField)
import Hanafuda.KoiKoi (GameID, PlayerID)
import qualified Data (RW(..))
import qualified Game (Key)
data Status =
LoggedIn Bool
| Answering PlayerKey
| Waiting PlayerKey
| Playing Game.Key
deriving (Show, Generic)
instance ToJSON Status where
toEncoding = genericToEncoding JSON.singleLCField
| Answering PlayerID
| Waiting PlayerID
| Playing GameID
deriving (Show)
data T = T {
connection :: Connection