Use the new APILanguage and simplify a lot of code

This commit is contained in:
Tissevert 2019-08-24 23:29:40 +02:00
parent 0f685c0a98
commit e9205b67c7
14 changed files with 229 additions and 411 deletions

View File

@ -1,5 +1,10 @@
# Revision history for hanafudapi
## 0.2.3.0 -- 2019-08-24
* Huge refactoring to use the new APILanguage that basically vampirized Game module which become more of a toolbox for the Automaton
* Fix a couple race conditions in JS client and server encountered when developping and testing Hannah the bot soon to come
## 0.2.2.0 -- 2019-08-12
* Handle the end of games

View File

@ -2,14 +2,14 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: hanafuda-webapp
version: 0.2.2.0
version: 0.2.3.0
synopsis: A webapp for the Haskell hanafuda library
-- description:
homepage: https://framagit.org/hanafuda
homepage: https://git.marvid.fr/hanafuda
license: BSD3
license-file: LICENSE
author: Sasha
maintainer: sasha+frama@marvid.fr
author: Tissevert
maintainer: tissevert+devel@marvid.fr
-- copyright:
category: Web
build-type: Simple
@ -17,26 +17,25 @@ extra-source-files: ChangeLog.md
cabal-version: >=1.10
source-repository head
type: git
location: https://framagit.org/hanafuda/api
location: https://git.marvid.fr/hanafuda/webapp
executable hanafudapi
main-is: Main.hs
other-modules: App
, Automaton
, Config
, Message
, Messaging
, Game
, JSON
, Data
, Player
, Server
, Session
-- other-extensions:
build-depends: base >=4.10 && <4.13
build-depends: base >=4.9 && <4.13
, bytestring
, containers
, containers >= 0.5.9
, unordered-containers
, hanafuda >= 0.3.0
, hanafuda >= 0.3.3
, hanafuda-APILanguage >= 0.1.0
, http-types
, aeson
, mtl

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 qualified Player (Key)
import Hanafuda.KoiKoi (PlayerID)
import qualified Session (T(..))
import qualified Server (T(..))
data Context = Context {
mServer :: MVar Server.T
, key :: Player.Key
, 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 :: Player.Key -> 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)

View File

@ -3,99 +3,102 @@ 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 (Game(..), 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)
import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, 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
)
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
(Message.relay logIn Message.broadcast >> setSessionStatus (Session.LoggedIn True))
(Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True))
sendError
receive (Session.LoggedIn True) logOut@Message.LogOut = do
Message.relay logOut Message.broadcast
asks App.key >>= App.update_ . Server.logOut
Messaging.relay logOut Messaging.broadcast
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))
Message.broadcast $ Message.update {Message.paired = [key, to]}
(Message.relay invitation $ Message.sendTo [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
Message.relay message $ Message.sendTo [to]
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
Message.notifyPlayers game []
return $ Session.Playing gameKey
gameID <- Game.new (for, to)
game <- Server.get gameID <$> App.server
Messaging.notifyPlayers game []
return $ Session.Playing gameID
else do
Message.broadcast $ Message.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
Message.notifyPlayers newGame logs
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
Message.broadcast $ Message.update {Message.alone = [key]}
playerID <- asks App.playerID
Messaging.broadcast $ Messaging.update {Message.alone = [playerID]}
setSessionStatus (Session.LoggedIn True)
_ -> sendError "Game is still running"
receive state _ = sendError $ "Invalid message in state " ++ show state
sendError :: String -> App.T ()
sendError = Message.send . Message.Error
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 ()
loop = do
message <- Message.get
message <- Messaging.get
status <- Session.status <$> App.current
status `receive` message
loop
@ -103,5 +106,5 @@ loop = do
start :: App.T ()
start = do
App.debug "Initial state"
Message.Welcome <$> App.server <*> asks App.key >>= Message.send
Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send
loop

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)

View File

@ -1,112 +1,40 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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 Data.Text (pack)
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 Data.HashMap.Strict (insert)
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), Value(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
import Data.Aeson.Types (toJSONKeyText)
import qualified JSON (defaultOptions, singleLCField)
import qualified Data (Key)
import qualified Player (Key)
import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
import qualified Hanafuda (empty)
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 qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play)
import GHC.Generics
import Hanafuda.Message (PublicGame)
import qualified Server (register)
deriving instance Generic Hanafuda.Card
deriving instance Generic Hanafuda.Flower
deriving instance Generic Hanafuda.KoiKoi.Action
deriving instance Generic Hanafuda.KoiKoi.Mode
deriving instance Generic Hanafuda.KoiKoi.Move
deriving instance Generic Hanafuda.KoiKoi.Yaku
deriving instance Generic Hanafuda.KoiKoi.Source
deriving instance Generic Hanafuda.KoiKoi.Step
deriving instance Generic1 (Hanafuda.Player.Player Player.Key)
deriving instance Generic1 (Hanafuda.Player.Players Player.Key)
new :: (PlayerID, PlayerID) -> App.T GameID
new (for, to) =
Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update
type T = Hanafuda.KoiKoi.Game Player.Key
deriving instance Generic T
instance ToJSON T where
toEncoding = genericToEncoding JSON.defaultOptions
instance FromJSON Hanafuda.Card
instance ToJSON Hanafuda.Card
instance ToJSON Hanafuda.Flower
instance ToJSON Hanafuda.Pack where
toJSON = toJSON . Hanafuda.cardsOfPack
toEncoding = toEncoding . Hanafuda.cardsOfPack
instance ToJSON Hanafuda.KoiKoi.Action
instance ToJSON Hanafuda.KoiKoi.Mode
instance FromJSON Hanafuda.KoiKoi.Move where
parseJSON = genericParseJSON JSON.singleLCField
instance ToJSON Hanafuda.KoiKoi.Move where
toEncoding = genericToEncoding JSON.singleLCField
instance ToJSON Hanafuda.KoiKoi.Source
instance ToJSON Hanafuda.KoiKoi.Step where
toEncoding = genericToEncoding JSON.defaultOptions
instance ToJSON1 (Hanafuda.Player.Player Player.Key) where
liftToEncoding = genericLiftToEncoding JSON.defaultOptions
instance ToJSON (Hanafuda.Player.Player Player.Key Hanafuda.KoiKoi.Score) where
toJSON = toJSON1
toEncoding = toEncoding1
instance ToJSON Hanafuda.KoiKoi.Yaku where
toEncoding = genericToEncoding JSON.defaultOptions
instance ToJSONKey Hanafuda.KoiKoi.Yaku where
toJSONKey = toJSONKeyText (pack . show)
instance ToJSON1 (Hanafuda.Player.Players Player.Key) where
liftToEncoding = genericLiftToEncoding JSON.defaultOptions
instance ToJSON (Hanafuda.Player.Players Player.Key Hanafuda.KoiKoi.Score) where
toJSON = toJSON1
toEncoding = toEncoding1
type Key = Data.Key T
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 game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast
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}
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 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"

View File

@ -1,27 +0,0 @@
module JSON (
defaultOptions
, distinct
, singleLCField
) where
import Data.Char (toLower)
import Data.Aeson (
Options(..)
, SumEncoding(..)
, defaultOptions
)
first :: (a -> a) -> [a] -> [a]
first _ [] = []
first f (x:xs) = f x:xs
singleLCField :: Options
singleLCField = defaultOptions {
constructorTagModifier = (toLower `first`)
, sumEncoding = ObjectWithSingleField
}
distinct :: Options
distinct = defaultOptions {
sumEncoding = UntaggedValue
}

View File

@ -14,21 +14,22 @@ import qualified Config (listenPort)
import qualified Session (open)
import qualified Server (disconnect, new, register)
import qualified App (Context(..), T, update_)
import qualified Message (FromClient(..), broadcast, relay)
import qualified Hanafuda.Message as Message (FromClient(..))
import Messaging (broadcast, relay)
import qualified Automaton (start)
exit :: App.T ()
exit = do
asks App.key >>= App.update_ . Server.disconnect
Message.relay Message.LogOut Message.broadcast
asks App.playerID >>= App.update_ . Server.disconnect
relay Message.LogOut broadcast
serverApp :: App.T () -> App.T () -> IO ServerApp
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)

View File

@ -1,105 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
module Message (
FromClient(..)
, T(..)
, broadcast
, get
, notifyPlayers
, receive
, relay
, send
, sendTo
, update
) where
import Data.List (intercalate)
import Data.Foldable (forM_)
import Data.Map (keys)
import Data.Aeson (FromJSON(..), ToJSON(..), Value, eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
import Network.WebSockets (receiveData, sendTextData)
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 Session (T(..))
import qualified Server (T(..), get)
import qualified App (Context(..), T, connection, debug, server)
import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), Move(..))
import GHC.Generics (Generic)
data FromClient =
Answer {accept :: Bool}
| Invitation {to :: Player.Key}
| LogIn {name :: Text}
| LogOut
| Play {move :: KoiKoi.Move}
| Quit
| Ping
deriving (Generic)
instance ToJSON FromClient where
toEncoding = genericToEncoding defaultOptions
instance FromJSON FromClient where
parseJSON = genericParseJSON defaultOptions
data T =
Relay {from :: Player.Key, message :: FromClient}
| Welcome {room :: Server.T, key :: Player.Key}
| Update {alone :: [Player.Key], paired :: [Player.Key]}
| Game {game :: Value, logs :: [KoiKoi.Action]}
| Pong
| Error {error :: String}
deriving (Generic)
instance ToJSON T where
toEncoding = genericToEncoding defaultOptions
sendTo :: [Player.Key] -> T -> App.T ()
sendTo playerKeys 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
send :: T -> App.T ()
send obj = do
key <- asks App.key
sendTo [key] obj
broadcast :: T -> App.T ()
broadcast obj =
App.server >>= flip sendTo obj . keys . Server.sessions
relay :: FromClient -> (T -> App.T ()) -> App.T ()
relay message f = do
App.debug "Relaying"
(\from -> f $ Relay {from, message}) =<< asks App.key
receive :: App.T FromClient
receive = do
received <- ((lift . receiveData) =<< App.connection)
App.debug $ '>':(unpack received)
case eitherDecode' received of
Left errorMessage -> send (Message.Error errorMessage) >> receive
Right clientMessage -> return clientMessage
get :: App.T Message.FromClient
get =
receive >>= pong
where
pong Ping = send Pong >> get
pong m = return m
update :: T
update = Update {alone = [], paired = []}
notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
notifyPlayers game logs =
forM_ (keys $ KoiKoi.scores game) $ \k ->
sendTo [k] $ Game {game = Game.export k game, logs}

76
src/Messaging.hs Normal file
View File

@ -0,0 +1,76 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Messaging (
FromClient(..)
, T(..)
, broadcast
, get
, notifyPlayers
, receive
, relay
, send
, sendTo
, update
) where
import Data.List (intercalate)
import Data.Foldable (forM_)
import Data.Map (keys)
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 (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, Game, GameBlueprint(..), PlayerID)
import qualified Hanafuda.Message as Message (T)
import Hanafuda.Message (FromClient(..), T(..))
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 = (\playerID -> Server.get playerID server) <$> playerIDs
recipients = show <$> playerIDs
send :: Message.T -> App.T ()
send obj = do
playerID <- asks App.playerID
sendTo [playerID] obj
broadcast :: Message.T -> App.T ()
broadcast obj =
App.server >>= flip sendTo obj . keys . Server.sessions
relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
relay message f = do
App.debug "Relaying"
(\from -> f $ Relay {from, message}) =<< asks App.playerID
receive :: App.T FromClient
receive = do
received <- ((lift . receiveData) =<< App.connection)
App.debug $ '>':(unpack received)
case eitherDecode' received of
Left errorMessage -> send (Error errorMessage) >> receive
Right clientMessage -> return clientMessage
get :: App.T FromClient
get =
receive >>= pong
where
pong Ping = send Pong >> get
pong m = return m
update :: T
update = Update {alone = [], paired = []}
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}

View File

@ -1,30 +0,0 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Player (
Key
, T(..)
) where
import Data.Text (Text)
import qualified Data (Key)
import GHC.Generics
data T = T {
name :: Text
} deriving (Eq, Ord, Generic)
type Key = Data.Key T
{-
instance FromJSON Key
instance ToJSON Key where
toEncoding = genericToEncoding JSON.defaultOptions
instance ToJSONKey Key where
toJSONKey = toJSONKeyText (pack . \(Key n) -> show n)
instance FromJSON Name
instance ToJSON Name where
toEncoding = genericToEncoding JSON.defaultOptions
-}

View File

@ -2,9 +2,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Server (
T(..)
, disconnect
@ -14,25 +12,24 @@ module Server (
, logOut
, new
, register
, room
, update
) where
import Data.Aeson (ToJSON(..), (.=), object, pairs)
import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
import qualified Data.Map as Map (empty)
import Data.Monoid ((<>))
import Data.Set (Set, member)
import qualified Data.Set as Set (delete, empty, insert)
import Data.Text (Text)
import Hanafuda.KoiKoi (Game, GameID, PlayerID)
import Hanafuda.Message (PlayerStatus(..), Room)
import qualified Data (RW(..))
import qualified Game (Key, T)
import qualified Player (Key, T(..))
import qualified Session (Status(..), T(..), Update)
type Names = Set Text
type Players = Map Player.Key Player.T
type Sessions = Map Player.Key Session.T
type Games = Map Game.Key Game.T
type Players = Map PlayerID Text
type Sessions = Map PlayerID Session.T
type Games = Map GameID Game
data T = T {
names :: Names
, players :: Players
@ -56,22 +53,16 @@ instance Data.RW Games T where
get = games
set games server = server {games}
newtype Player = Player (Text, Bool)
instance ToJSON Player where
toJSON (Player (name, alone)) = object ["name" .= name, "alone" .= alone]
toEncoding (Player (name, alone)) = pairs ("name" .= name <> "alone" .= alone)
export :: Sessions -> Player.Key -> Player.T -> Player
export sessions key player = Player (Player.name player, alone)
export :: Sessions -> PlayerID -> Text -> PlayerStatus
export sessions playerID playerName = PlayerStatus (playerName, alone)
where
alone =
case Session.status (sessions ! key) of
case Session.status (sessions ! playerID) of
Session.LoggedIn True -> True
_ -> False
instance ToJSON T where
toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players
room :: T -> Room
room (T {players, sessions}) = mapWithKey (export sessions) players
new :: T
new = T {
@ -83,39 +74,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 :: Player.Key -> 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 -> Player.Key -> 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 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 :: Player.Key -> 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 (Set.delete $ Player.name player :: Names -> Names) server)
(players server !? key)
(\playerName ->
Data.update (delete playerID :: Players -> Players) $
update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $
Data.update (Set.delete playerName :: Names -> Names) server)
(players server !? playerID)

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 qualified JSON (singleLCField)
import Hanafuda.KoiKoi (GameID, PlayerID)
import qualified Data (RW(..))
import qualified Player (Key)
import qualified Game (Key)
data Status =
LoggedIn Bool
| Answering Player.Key
| Waiting Player.Key
| 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

View File

@ -11,16 +11,6 @@ function Game(modules) {
var selected = null;
var queue = [];
window.addEventListener('focus', runQueue);
modules.messaging.addEventListener(["Game"], function(o) {
if(document.hasFocus()) {
modules.async.run(handleGameMessage(o));
} else {
modules.statusHandler.set("♪");
queue.push(handleGameMessage(o));
}
});
function buildSets() {
var sets = {};
['river', 'you', 'them'].forEach(function(id) {
@ -39,10 +29,24 @@ function Game(modules) {
return sets;
}
window.addEventListener('focus', runQueue);
modules.messaging.addEventListener(["Game"], function(o) {
queue.push(handleGameMessage(o));
if(document.hasFocus() && queue.length == 1) {
runQueue();
} else {
modules.statusHandler.set("♪");
}
});
function runQueue() {
if(queue.length > 0) {
var length = queue.length;
modules.async.run.apply(null, queue.concat(
modules.async.apply(function() {queue = [];})
modules.async.apply(function() {
queue = queue.slice(length);
runQueue();
})
));
}
}