Use the new APILanguage and simplify a lot of code

ChangeLog.md

@@ -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

hanafuda-webapp.cabal

@@ -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
+author:              Tissevert
-maintainer:          sasha+frama@marvid.fr
+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

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 :: PlayerID -> T Session.T
-get key =
+get playerID =
-  (! key) . Server.sessions <$> server
+  (! 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)

src/Automaton.hs

@@ -3,99 +3,102 @@ module Automaton (
     start
   ) where
 
-import Control.Monad.Except (runExceptT)
+import Control.Monad.Reader (asks)
-import Control.Monad.Reader (asks, lift)
-import Control.Monad.Writer (runWriterT)
 import qualified Data (RW(..))
 import Data.Map (Map, (!?))
-import qualified Game (Key, T, new, play)
+import qualified Game (new, play)
-import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), Step(..))
+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 Server (endGame, get, logIn, logOut, update, room)
-import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
+import qualified App (Context(..), T, current, debug, get, server, try, update_)
-import qualified Message (FromClient(..), T(..), broadcast, get, notifyPlayers, relay, send, sendTo, 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
+  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
+      from <- asks App.playerID
-      App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update))
+      App.update_ (Server.update to (Data.set $ Session.Answering from :: Session.Update))
-      Message.broadcast $ Message.update {Message.paired = [key, to]}
+      Messaging.broadcast $ Messaging.update {Message.paired = [from, to]}
-      (Message.relay invitation $ Message.sendTo [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
-      Message.relay message $ Message.sendTo [to]
+      Messaging.relay message $ Messaging.sendTo [to]
       newStatus <-
         if accept
           then do
-            gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
+            gameID <- Game.new (for, to)
-            game <- Server.get gameKey <$> App.server
+            game <- Server.get gameID <$> App.server
-            Message.notifyPlayers game []
+            Messaging.notifyPlayers game []
-            return $ Session.Playing gameKey
+            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
+receive (Session.Playing gameID) played@(Message.Play {}) = do
-  key <- asks App.key
+  playerID <- asks App.playerID
-  game <- Server.get gameKey <$> App.server
+  game <- Server.get gameID <$> App.server
-  (result, logs) <- lift . runWriterT . runExceptT $ Game.play key (Message.move played) game
+  (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.debug $ "Game " ++ show gameID ++ " ended"
-          App.update_ $ Server.endGame gameKey
+          App.update_ $ Server.endGame gameID
-        _ -> App.update_ $ Server.update gameKey (const newGame)
+        _ -> App.update_ $ Server.update gameID (const newGame)
+      Messaging.notifyPlayers newGame logs
 
-receive (Session.Playing gameKey) Message.Quit = do
+receive (Session.Playing gameID) Message.Quit = do
-  games <- (Data.get <$> App.server :: App.T (Map Game.Key Game.T))
+  games <- (Data.get <$> App.server :: App.T (Map KoiKoi.GameID KoiKoi.Game))
-  case games !? gameKey of
+  case games !? gameID of
     Nothing -> do
-      key <- asks App.key
+      playerID <- asks App.playerID
-      Message.broadcast $ Message.update {Message.alone = [key]}
+      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
+  playerID <- asks App.playerID
-  App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
+  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

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)

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
+      export
-    , T
-    , export
     , new
     , play
   ) where
 
-import Control.Monad.Except (throwError)
+import qualified App (T, update)
-import Data.Text (pack)
+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 qualified Hanafuda (empty)
-import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), Value(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
+import qualified Hanafuda.KoiKoi as KoiKoi (
-import Data.Aeson.Types (toJSONKeyText)
+    Action, Move(..), play, new
-import qualified JSON (defaultOptions, singleLCField)
+  )
-import qualified Data (Key)
+import Hanafuda.KoiKoi (Game, GameBlueprint(..), GameID, Mode(..), PlayerID)
-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(..), Score, Source(..), Step(..), Yaku(..), new, play)
+import Hanafuda.Message (PublicGame)
-import GHC.Generics
+import qualified Server (register)
 
-deriving instance Generic Hanafuda.Card
+new :: (PlayerID, PlayerID) -> App.T GameID
-deriving instance Generic Hanafuda.Flower
+new (for, to) =
-deriving instance Generic Hanafuda.KoiKoi.Action
+  Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update
-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)
 
-type T = Hanafuda.KoiKoi.Game Player.Key
+export :: PlayerID -> Game -> PublicGame
-
+export playerID game = game {
-deriving instance Generic T
+      deck = length $ deck game
-
+    , players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
-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
   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 :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action])
-play key move game
+play playerID move game = lift . runWriterT . runExceptT $
-  | Hanafuda.KoiKoi.playing game == key =
+  if playing game == playerID
-    Hanafuda.KoiKoi.play move game
+  then KoiKoi.play move game
-  | otherwise = throwError "Not your turn"
+  else throwError "Not your turn"

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
-  }

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
+  asks App.playerID >>= App.update_ . Server.disconnect
-  Message.relay Message.LogOut Message.broadcast
+  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)
+    playerID <- modifyMVar mServer (return . Server.register session)
-    let app = App.Context {App.mServer, App.key}
+    let app = App.Context {App.mServer, App.playerID}
     finally
       (runReaderT onEnter app)
       (runReaderT onExit app)

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}

src/Messaging.hs

@@ -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}

src/Player.hs

@@ -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
--}

src/Server.hs

@@ -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 Players = Map PlayerID Text
-type Sessions = Map Player.Key Session.T
+type Sessions = Map PlayerID Session.T
-type Games = Map Game.Key Game.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)
+export :: Sessions -> PlayerID -> Text -> PlayerStatus
-instance ToJSON Player where
+export sessions playerID playerName = PlayerStatus (playerName, alone)
-  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)
   where
     alone =
-      case Session.status (sessions ! key) of
+      case Session.status (sessions ! playerID) of
         Session.LoggedIn True -> True
         _ -> False
 
-instance ToJSON T where
+room :: T -> Room
-  toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
+room (T {players, sessions}) = mapWithKey (export sessions) players
-  toEncoding (T {players, sessions}) = toEncoding $ 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
+  let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
-  (Data.update (insert key x) server, key)
+  (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 =
+update playerID updator =
-  Data.update (adjust updator key :: Map a b -> Map a b)
+  Data.update (adjust updator playerID :: Map a b -> Map a b)
 
-disconnect :: Player.Key -> T -> T
+disconnect :: PlayerID -> T -> T
-disconnect key =
+disconnect playerID =
-  Data.update (delete key :: Sessions -> Sessions) . logOut key
+  Data.update (delete playerID :: Sessions -> Sessions) . logOut playerID
 
-endGame :: Game.Key -> T -> T
+endGame :: GameID -> T -> T
-endGame key =
+endGame playerID =
-  Data.update (delete key :: Games -> Games)
+  Data.update (delete playerID :: Games -> Games)
 
-logIn :: Text -> Player.Key -> T -> Either String T
+logIn :: Text -> PlayerID -> T -> Either String T
-logIn name key server =
+logIn name playerID server =
   Data.update (Set.insert name) .
-  Data.update (insert key $ Player.T {Player.name}) .
+  Data.update (insert playerID name) .
-  update key (Data.set $ Session.LoggedIn True :: Session.Update) <$>
+  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 :: PlayerID -> T -> T
-logOut key server =
+logOut playerID server =
   maybe
     server
-    (\player ->
+    (\playerName ->
-      Data.update (delete key :: Players -> Players) $
+      Data.update (delete playerID :: Players -> Players) $
-      update key (Data.set $ Session.LoggedIn False :: Session.Update) $
+      update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $
-      Data.update (Set.delete $ Player.name player :: Names -> Names) server)
+      Data.update (Set.delete playerName :: Names -> Names) server)
-    (players server !? key)
+    (players server !? playerID)

src/Session.hs

@@ -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 Hanafuda.KoiKoi (GameID, PlayerID)
-import GHC.Generics (Generic)
-import qualified JSON (singleLCField)
 import qualified Data (RW(..))
-import qualified Player (Key)
-import qualified Game (Key)
 
 data Status =
     LoggedIn Bool
-  | Answering Player.Key
+  | Answering PlayerID
-  | Waiting Player.Key
+  | Waiting PlayerID
-  | Playing Game.Key
+  | Playing GameID
-  deriving (Show, Generic)
+  deriving (Show)
-
-instance ToJSON Status where
-  toEncoding = genericToEncoding JSON.singleLCField
 
 data T = T {
       connection :: Connection

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();
+				})
 			));
 		}
 	}