hanafuda-protocol.cabal

@@ -23,8 +23,6 @@ library
   -- other-extensions:
   build-depends:       aeson
                      , base >=4.9 && <4.13
-                     , base64-bytestring
-                     , bytestring
                      , containers
                      , hanafuda >= 0.3.3
                      , text

src/Hanafuda/Message.hs

@@ -3,56 +3,42 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Hanafuda.Message (
       T(..)
     , FromClient(..)
-    , Coordinates(..)
-    , PrivateState(..)
-    , PublicGame(..)
-    , PublicPlayer(..)
-    , PublicState(..)
+    , PlayerStatus(..)
+    , PublicGame
     , Room
-    , orderCoordinates
   ) where
 
 import Data.Char (toLower)
 import Data.Aeson (
       FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..)
-    , Value(..), (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
-    , genericToEncoding, object, pairs, withObject, withText
+    , Value, (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
+    , genericToEncoding, object, pairs, withObject
   )
 import Data.Aeson.Types (toJSONKeyText)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Base64 as B64 (decode, encode)
 import Data.Map (Map)
 import Data.Monoid ((<>))
 import Data.Text (Text)
 import qualified Data.Text as Text (pack, unpack)
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import GHC.Generics (Generic)
 import qualified Hanafuda (Card(..), Flower(..), Pack, cardsOfPack, empty, packOfCards)
-import Hanafuda.ID (ID(..), IDType(..), Prefix(..))
-import Hanafuda.KoiKoi (GameID, PlayerID)
+import Hanafuda.ID (ID(..), getID)
+import Hanafuda.KoiKoi (PlayerID, GameBlueprint(..))
 import qualified Hanafuda.KoiKoi as KoiKoi (
-      Action(..), Game(..), Mode(..), Move(..), Player(..), Players(..), PlayerTurn
-    , Score, Scores, Source(..), Step(..), Yaku(..)
+    Action(..), Game(..), Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..)
   )
 import Hanafuda.Player (Player(..), Players(..))
-import Text.Read (readMaybe)
 
-instance IDType a => FromJSON (ID a) where
-  parseJSON = withText decoding (safeRead . Text.unpack)
-    where
-      decoding = let Prefix p = (prefix :: Prefix a) in p ++ "ID"
-      safeRead s = maybe (fail $ "Not an ID: '" ++ s ++ "'") return $ readMaybe s
-instance IDType a => FromJSONKey (ID a) where
-  fromJSONKey = FromJSONKeyText (read . Text.unpack)
-instance IDType a => ToJSON (ID a) where
-  toJSON = toJSON . show
-  toEncoding = toEncoding . show
-instance IDType a => ToJSONKey (ID a) where
-  toJSONKey = toJSONKeyText (Text.pack . show)
+deriving instance Generic PlayerID
+instance FromJSON PlayerID
+instance FromJSONKey PlayerID where
+  fromJSONKey = FromJSONKeyText (ID . read . Text.unpack)
+instance ToJSON PlayerID where
+  toEncoding = genericToEncoding defaultOptions
+instance ToJSONKey PlayerID where
+  toJSONKey = toJSONKeyText (Text.pack . getID)
 
 first :: (a -> a) -> [a] -> [a]
 first _ [] = []
@@ -76,23 +62,32 @@ instance ToJSON Hanafuda.Card where
   toEncoding = genericToEncoding defaultOptions
 
 data FromClient =
-    Hello {name :: Text}
-  | Tadaima {myID :: PlayerID, name :: Text}
-  | Answer {accept :: Bool, to :: PlayerID}
+    Answer {accept :: Bool}
   | Invitation {to :: PlayerID}
-  | Play {move :: KoiKoi.Move, onGame :: PublicGame}
-  | Share {gameSave :: PublicGame}
-  | Sync {latestKnown :: Coordinates, to :: PlayerID}
-  | Yield {onGameID :: GameID, to :: PlayerID}
+  | LogIn {name :: Text}
+  | LogOut
+  | Play {move :: KoiKoi.Move}
   | Quit
   | Ping
-  deriving (Generic, Show)
+  deriving (Generic)
 
 instance FromJSON FromClient
 instance ToJSON FromClient where
   toEncoding = genericToEncoding defaultOptions
 
-type Room = Map PlayerID Text
+newtype PlayerStatus = PlayerStatus (Text, Bool) deriving (Generic, Show)
+
+instance FromJSON PlayerStatus where
+  parseJSON = withObject "PlayerStatus" $ \v -> fmap PlayerStatus . (,)
+    <$> v .: "name"
+    <*> v .: "alone"
+instance ToJSON PlayerStatus where
+  toJSON (PlayerStatus (name, alone)) =
+    object ["name" .= name, "alone" .= alone]
+  toEncoding (PlayerStatus (name, alone)) =
+    pairs ("name" .= name <> "alone" .= alone)
+
+type Room = Map PlayerID PlayerStatus
 
 deriving instance Generic KoiKoi.Source
 instance FromJSON KoiKoi.Source
@@ -113,14 +108,14 @@ instance ToJSON KoiKoi.Yaku where
 instance ToJSONKey KoiKoi.Yaku where
   toJSONKey = toJSONKeyText (Text.pack . show)
 
-deriving instance Generic KoiKoi.Player
-instance FromJSON KoiKoi.Player
-instance ToJSON KoiKoi.Player where
+deriving instance Generic (Player KoiKoi.Score)
+instance FromJSON (Player KoiKoi.Score)
+instance ToJSON (Player KoiKoi.Score) where
   toEncoding = genericToEncoding defaultOptions
 
-deriving instance Generic KoiKoi.Players
-instance FromJSON KoiKoi.Players
-instance ToJSON KoiKoi.Players where
+deriving instance Generic (Players KoiKoi.Score)
+instance FromJSON (Players KoiKoi.Score)
+instance ToJSON (Players KoiKoi.Score) where
   toEncoding = genericToEncoding defaultOptions
 
 deriving instance Generic KoiKoi.Step
@@ -144,76 +139,9 @@ instance FromJSON Hanafuda.Flower
 instance ToJSON Hanafuda.Flower where
   toEncoding = genericToEncoding defaultOptions
 
-data Coordinates = Coordinates {
-      gameID :: GameID
-    , month :: Hanafuda.Flower
-    , turn :: Int
-  } deriving (Eq, Generic, Show)
-
-instance FromJSON Coordinates
-instance ToJSON Coordinates where
-  toEncoding = genericToEncoding defaultOptions
-
-orderCoordinates :: Coordinates -> Coordinates -> Maybe Ordering
-orderCoordinates coordinatesA coordinatesB
-  | gameID coordinatesA == gameID coordinatesB = Just $ compare
-    (month coordinatesA, turn coordinatesA)
-    (month coordinatesB, turn coordinatesB)
-  | otherwise = Nothing
-
-data PrivateState = PrivateState {
-      link :: Coordinates
-    , hands :: Map PlayerID Hanafuda.Pack
-    , deck :: [Hanafuda.Card]
-  } deriving Generic
-
-instance FromJSON PrivateState
-instance ToJSON PrivateState where
-  toEncoding = genericToEncoding defaultOptions
-
-data PublicPlayer = PublicPlayer {
-      meld :: Hanafuda.Pack
-    , yakus :: KoiKoi.Score
-  } deriving (Generic, Show)
-
-instance FromJSON PublicPlayer
-instance ToJSON PublicPlayer where
-  toEncoding = genericToEncoding defaultOptions
-
-data PublicState = PublicState {
-      coordinates :: Coordinates
-    , mode :: KoiKoi.Mode
-    , scores :: KoiKoi.Scores
-    , nextPlayer :: KoiKoi.PlayerTurn
-    , players :: Map PlayerID PublicPlayer
-    , playing :: PlayerID
-    , winning :: PlayerID
-    , oyake :: PlayerID
-    , river :: Hanafuda.Pack
-    , step :: KoiKoi.Step
-    , trick :: [Hanafuda.Card]
-    , rounds :: [(PlayerID, KoiKoi.Score)]
-  } deriving (Generic, Show)
-
-instance FromJSON PublicState
-instance ToJSON PublicState where
-  toEncoding = genericToEncoding defaultOptions
-
-instance FromJSON ByteString where
-  parseJSON = withText "ByteString" (either fail return . B64.decode . encodeUtf8)
-instance ToJSON ByteString where
-  toJSON = String . decodeUtf8 . B64.encode
-  toEncoding = toEncoding . decodeUtf8 . B64.encode
-
-data PublicGame = PublicGame {
-      nonce :: ByteString
-    , logs :: [KoiKoi.Action]
-    , playerHand :: Hanafuda.Pack
-    , private :: ByteString
-    , public :: PublicState
-    , publicSignature :: ByteString
-  } deriving (Generic, Show)
+type PublicGame = GameBlueprint Int
 
+deriving instance Generic PublicGame
 instance FromJSON PublicGame
 instance ToJSON PublicGame where
   toEncoding = genericToEncoding defaultOptions
@@ -221,10 +149,8 @@ instance ToJSON PublicGame where
 data T =
     Relay {from :: PlayerID, message :: FromClient}
   | Welcome {room :: Room, key :: PlayerID}
-  | Okaeri {room :: Room}
-  | LogIn {from :: PlayerID, as :: Text}
-  | LogOut {from :: PlayerID}
-  | Game {state :: PublicGame}
+  | Update {alone :: [PlayerID], paired :: [PlayerID]}
+  | Game {game :: PublicGame, logs :: [KoiKoi.Action]}
   | Pong
   | Error {error :: String}
   deriving (Generic)