Use the new APILanguage and simplify a lot of code
This commit is contained in:
parent
0f685c0a98
commit
e9205b67c7
14 changed files with 229 additions and 411 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
14
src/App.hs
14
src/App.hs
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
21
src/Data.hs
21
src/Data.hs
|
|
@ -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)
|
||||
|
|
|
|||
124
src/Game.hs
124
src/Game.hs
|
|
@ -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"
|
||||
|
|
|
|||
27
src/JSON.hs
27
src/JSON.hs
|
|
@ -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
|
||||
}
|
||||
11
src/Main.hs
11
src/Main.hs
|
|
@ -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)
|
||||
|
|
|
|||
105
src/Message.hs
105
src/Message.hs
|
|
@ -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
76
src/Messaging.hs
Normal 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}
|
||||
|
|
@ -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
|
||||
-}
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
26
www/game.js
26
www/game.js
|
|
@ -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();
|
||||
})
|
||||
));
|
||||
}
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue