Use new PlayerKey type in lib and Message module from the separate APILanguage

hanafuda-webapp.cabal

@@ -24,7 +24,7 @@ executable hanafudapi
   other-modules:       App
                      , Automaton
                      , Config
-                     , Message
+                     , Messaging
                      , Game
                      , JSON
                      , Data
@@ -37,6 +37,7 @@ executable hanafudapi
                      , containers
                      , unordered-containers
                      , hanafuda >= 0.3.0
+                     , hanafuda-APILanguage
                      , 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 (PlayerKey)
 import qualified Session (T(..))
 import qualified Server (T(..))
 
 data Context = Context {
       mServer :: MVar Server.T
-    , key :: Player.Key
+    , key :: PlayerKey
   }
 
 type T a = ReaderT Context IO a
@@ -30,7 +30,7 @@ type T a = ReaderT Context IO a
 server :: T Server.T
 server = asks mServer >>= lift . readMVar
 
-get :: Player.Key -> T Session.T
+get :: PlayerKey -> T Session.T
 get key =
   (! key) . Server.sessions <$> server
 

src/Automaton.hs

@@ -11,20 +11,21 @@ import Data.Map (Map, (!?))
 import qualified Game (Key, T, new, play)
 import qualified Hanafuda.KoiKoi as KoiKoi (Game(..), Step(..))
 import qualified Session (Status(..), T(..), Update)
-import qualified Server (endGame, get, logIn, logOut, update, register)
+import qualified Server (endGame, get, logIn, logOut, update, register, room)
 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 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)
   >>= 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
   setSessionStatus (Session.LoggedIn False)
 
@@ -34,8 +35,8 @@ receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = d
     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]}
+      Messaging.broadcast $ Messaging.update {Message.paired = [key, to]}
-      (Message.relay invitation $ Message.sendTo [to])
+      (Messaging.relay invitation $ Messaging.sendTo [to])
       setSessionStatus (Session.Waiting to)
     _ -> sendError "They just left"
 
@@ -44,16 +45,16 @@ receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
   key <- asks App.key
   case Session.status session of
     Session.Waiting for | for == key -> 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
             game <- Server.get gameKey <$> App.server
-            Message.notifyPlayers game []
+            Messaging.notifyPlayers game []
             return $ Session.Playing gameKey
           else do
-            Message.broadcast $ Message.update {Message.alone = [key, to]}
+            Messaging.broadcast $ Messaging.update {Message.alone = [key, to]}
             return $ Session.LoggedIn True
       App.update_ $ Server.update to (Data.set newStatus :: Session.Update)
       setSessionStatus newStatus
@@ -66,7 +67,7 @@ receive (Session.Playing gameKey) played@(Message.Play {}) = do
   case result of
     Left message -> sendError message
     Right newGame -> do
-      Message.notifyPlayers newGame logs
+      Messaging.notifyPlayers newGame logs
       case KoiKoi.step newGame of
         KoiKoi.Over -> do
           App.debug $ "Game " ++ show gameKey ++ " ended"
@@ -78,14 +79,14 @@ receive (Session.Playing gameKey) Message.Quit = do
   case games !? gameKey of
     Nothing -> do
       key <- asks App.key
-      Message.broadcast $ Message.update {Message.alone = [key]}
+      Messaging.broadcast $ Messaging.update {Message.alone = [key]}
       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
@@ -95,7 +96,7 @@ setSessionStatus newStatus = do
 
 loop :: App.T ()
 loop = do
-  message <- Message.get
+  message <- Messaging.get
   status <- Session.status <$> App.current
   status `receive` message
   loop
@@ -103,5 +104,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.key >>= Messaging.send
   loop

src/Game.hs

@@ -18,29 +18,26 @@ import Control.Monad.Except (throwError)
 import Data.Text (pack)
 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 (ToJSON(..), ToJSONKey(..), Value(..), defaultOptions, genericToEncoding)
 import Data.Aeson.Types (toJSONKeyText)
-import qualified JSON (defaultOptions, singleLCField)
 import qualified Data (Key)
-import qualified Player (Key)
+import qualified Hanafuda (Flower(..), Pack, cardsOfPack, empty)
-import qualified Hanafuda (Flower(..), Card(..), Pack, cardsOfPack, empty)
+import qualified Hanafuda.KoiKoi (Game(..), Environment, Mode(..), Move(..), PlayerKey, Score, Step(..), Yaku(..), new, play)
 import qualified Hanafuda.Player (Player(..), Players(..))
-import qualified Hanafuda.KoiKoi (Action(..), Game(..), Environment, Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..), new, play)
+import Hanafuda.Message()
 import GHC.Generics
 
 deriving instance Generic Hanafuda.Flower
 deriving instance Generic Hanafuda.KoiKoi.Mode
 deriving instance Generic Hanafuda.KoiKoi.Yaku
 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
+type T = Hanafuda.KoiKoi.Game
 
 deriving instance Generic T
 
 instance ToJSON T where
-  toEncoding = genericToEncoding JSON.defaultOptions
+  toEncoding = genericToEncoding defaultOptions
 
 instance ToJSON Hanafuda.Flower
 
@@ -51,34 +48,28 @@ instance ToJSON Hanafuda.Pack where
 instance ToJSON Hanafuda.KoiKoi.Mode
 
 instance ToJSON Hanafuda.KoiKoi.Step where
-  toEncoding = genericToEncoding JSON.defaultOptions
+  toEncoding = genericToEncoding defaultOptions
 
-instance ToJSON1 (Hanafuda.Player.Player Player.Key) where
+instance ToJSON (Hanafuda.Player.Player Hanafuda.KoiKoi.Score) where
-  liftToEncoding = genericLiftToEncoding JSON.defaultOptions
+  toJSON = toJSON
-
+  toEncoding = toEncoding
-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
+  toEncoding = genericToEncoding defaultOptions
 instance ToJSONKey Hanafuda.KoiKoi.Yaku where
   toJSONKey = toJSONKeyText (pack . show)
 
-instance ToJSON1 (Hanafuda.Player.Players Player.Key) where
+instance ToJSON (Hanafuda.Player.Players Hanafuda.KoiKoi.Score) where
-  liftToEncoding = genericLiftToEncoding JSON.defaultOptions
+  toJSON = toJSON
-
+  toEncoding = toEncoding
-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 :: Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.PlayerKey -> IO T
 new p1 p2 = do
   Hanafuda.KoiKoi.new [p1, p2] $ Hanafuda.KoiKoi.WholeYear
 
-export :: Player.Key -> T -> Value
+export :: Hanafuda.KoiKoi.PlayerKey -> T -> Value
 export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck game) $ ast
   where
     Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game
@@ -89,7 +80,7 @@ export key game = Object $ insert "deck" (toJSON $ length $ Hanafuda.KoiKoi.deck
         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 :: Hanafuda.KoiKoi.Environment m => Hanafuda.KoiKoi.PlayerKey -> Hanafuda.KoiKoi.Move -> T -> m T
 play key move game
   | Hanafuda.KoiKoi.playing game == key =
     Hanafuda.KoiKoi.play move game

src/Main.hs

@@ -14,13 +14,14 @@ 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
+  relay Message.LogOut broadcast
 
 serverApp :: App.T () -> App.T () -> IO ServerApp
 serverApp onEnter onExit = do

src/Messaging.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
-module Message (
+module Messaging (
       FromClient(..)
     , T(..)
     , broadcast
@@ -17,20 +16,19 @@ module Message (
 import Data.List (intercalate)
 import Data.Foldable (forM_)
 import Data.Map (keys)
-import Data.Aeson (FromJSON(..), ToJSON(..), Value, eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
+import Data.Aeson (eitherDecode', encode)
 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 qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerKey)
-import GHC.Generics (Generic)
+import qualified Hanafuda.Message as Message (T)
+import Hanafuda.Message (FromClient(..), T(..))
 
-sendTo :: [Player.Key] -> T -> App.T ()
+sendTo :: [KoiKoi.PlayerKey] -> Message.T -> App.T ()
 sendTo playerKeys obj = do
   sessions <- getSessions <$> App.server
   App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
@@ -40,16 +38,16 @@ sendTo playerKeys obj = do
     getSessions server = (\key -> Server.get key server) <$> playerKeys
     recipients = show <$> playerKeys
 
-send :: T -> App.T ()
+send :: Message.T -> App.T ()
 send obj = do
   key <- asks App.key
   sendTo [key] obj
 
-broadcast :: T -> App.T ()
+broadcast :: Message.T -> App.T ()
 broadcast obj =
   App.server >>= flip sendTo obj . keys . Server.sessions
 
-relay :: FromClient -> (T -> App.T ()) -> App.T ()
+relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
 relay message f = do
   App.debug "Relaying"
   (\from -> f $ Relay {from, message}) =<< asks App.key
@@ -59,10 +57,10 @@ receive = do
   received <- ((lift . receiveData) =<< App.connection)
   App.debug $ '>':(unpack received)
   case eitherDecode' received of
-    Left errorMessage -> send (Message.Error errorMessage) >> receive
+    Left errorMessage -> send (Error errorMessage) >> receive
     Right clientMessage -> return clientMessage
 
-get :: App.T Message.FromClient
+get :: App.T FromClient
 get =
   receive >>= pong
   where

src/Player.hs

@@ -3,18 +3,15 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Player (
-      Key
+    T(..)
-    , 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

src/Server.hs

@@ -14,24 +14,25 @@ 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 (PlayerKey)
+import Hanafuda.Message (PlayerStatus(..), Room)
 import qualified Data (RW(..))
 import qualified Game (Key, T)
-import qualified Player (Key, T(..))
+import qualified Player (T(..))
 import qualified Session (Status(..), T(..), Update)
 
 type Names = Set Text
-type Players = Map Player.Key Player.T
+type Players = Map PlayerKey Player.T
-type Sessions = Map Player.Key Session.T
+type Sessions = Map PlayerKey Session.T
 type Games = Map Game.Key Game.T
 data T = T {
       names :: Names
@@ -56,22 +57,22 @@ instance Data.RW Games T where
   get = games
   set games server = server {games}
 
-newtype Player = Player (Text, Bool)
+export :: Sessions -> PlayerKey -> Player.T -> PlayerStatus
-instance ToJSON Player where
+export sessions key player = PlayerStatus (Player.name player, 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
         Session.LoggedIn True -> True
         _ -> False
 
+room :: T -> Room
+room (T {players, sessions}) = mapWithKey (export sessions) players
+
+{-
 instance ToJSON T where
   toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
   toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players
+-}
 
 new :: T
 new = T {
@@ -93,7 +94,7 @@ 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)
 
-disconnect :: Player.Key -> T -> T
+disconnect :: PlayerKey -> T -> T
 disconnect key =
   Data.update (delete key :: Sessions -> Sessions) . logOut key
 
@@ -101,7 +102,7 @@ endGame :: Game.Key -> T -> T
 endGame key =
   Data.update (delete key :: Games -> Games)
 
-logIn :: Text -> Player.Key -> T -> Either String T
+logIn :: Text -> PlayerKey -> T -> Either String T
 logIn name key server =
   Data.update (Set.insert name) .
   Data.update (insert key $ Player.T {Player.name}) .
@@ -110,7 +111,7 @@ logIn name key server =
     then Left "This name is already registered"
     else Right server
 
-logOut :: Player.Key -> T -> T
+logOut :: PlayerKey -> T -> T
 logOut key server =
   maybe
     server

src/Session.hs

@@ -11,15 +11,15 @@ module Session (
 import Network.WebSockets (Connection)
 import Data.Aeson (ToJSON(..), genericToEncoding)
 import GHC.Generics (Generic)
+import Hanafuda.KoiKoi (PlayerKey)
 import qualified JSON (singleLCField)
 import qualified Data (RW(..))
-import qualified Player (Key)
 import qualified Game (Key)
 
 data Status =
     LoggedIn Bool
-  | Answering Player.Key
+  | Answering PlayerKey
-  | Waiting Player.Key
+  | Waiting PlayerKey
   | Playing Game.Key
   deriving (Show, Generic)