Implement a partial ordering on game coordinates to allow implementing re-synchronization easily

hanafuda-protocol.cabal

@@ -23,6 +23,8 @@ 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,42 +3,56 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Hanafuda.Message (
       T(..)
     , FromClient(..)
-    , PlayerStatus(..)
-    , PublicGame
+    , Coordinates(..)
+    , PrivateState(..)
+    , PublicGame(..)
+    , PublicPlayer(..)
+    , PublicState(..)
     , 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
+    , Value(..), (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
+    , genericToEncoding, object, pairs, withObject, withText
   )
 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(..), getID)
-import Hanafuda.KoiKoi (PlayerID, GameBlueprint(..))
+import Hanafuda.ID (ID(..), IDType(..), Prefix(..))
+import Hanafuda.KoiKoi (GameID, PlayerID)
 import qualified Hanafuda.KoiKoi as KoiKoi (
-    Action(..), Game(..), Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..)
+      Action(..), Game(..), Mode(..), Move(..), Player(..), Players(..), PlayerTurn
+    , Score, Scores, Source(..), Step(..), Yaku(..)
   )
 import Hanafuda.Player (Player(..), Players(..))
+import Text.Read (readMaybe)
 
-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)
+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)
 
 first :: (a -> a) -> [a] -> [a]
 first _ [] = []
@@ -62,32 +76,23 @@ instance ToJSON Hanafuda.Card where
   toEncoding = genericToEncoding defaultOptions
 
 data FromClient =
-    Answer {accept :: Bool}
+    Hello {name :: Text}
+  | Tadaima {myID :: PlayerID, name :: Text}
+  | Answer {accept :: Bool, to :: PlayerID}
   | Invitation {to :: PlayerID}
-  | LogIn {name :: Text}
-  | LogOut
-  | Play {move :: KoiKoi.Move}
+  | Play {move :: KoiKoi.Move, onGame :: PublicGame}
+  | Share {gameSave :: PublicGame}
+  | Sync {latestKnown :: Coordinates, to :: PlayerID}
+  | Yield {onGameID :: GameID, to :: PlayerID}
   | Quit
   | Ping
-  deriving (Generic)
+  deriving (Generic, Show)
 
 instance FromJSON FromClient
 instance ToJSON FromClient where
   toEncoding = genericToEncoding defaultOptions
 
-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
+type Room = Map PlayerID Text
 
 deriving instance Generic KoiKoi.Source
 instance FromJSON KoiKoi.Source
@@ -108,14 +113,14 @@ instance ToJSON KoiKoi.Yaku where
 instance ToJSONKey KoiKoi.Yaku where
   toJSONKey = toJSONKeyText (Text.pack . show)
 
-deriving instance Generic (Player KoiKoi.Score)
-instance FromJSON (Player KoiKoi.Score)
-instance ToJSON (Player KoiKoi.Score) where
+deriving instance Generic KoiKoi.Player
+instance FromJSON KoiKoi.Player
+instance ToJSON KoiKoi.Player where
   toEncoding = genericToEncoding defaultOptions
 
-deriving instance Generic (Players KoiKoi.Score)
-instance FromJSON (Players KoiKoi.Score)
-instance ToJSON (Players KoiKoi.Score) where
+deriving instance Generic KoiKoi.Players
+instance FromJSON KoiKoi.Players
+instance ToJSON KoiKoi.Players where
   toEncoding = genericToEncoding defaultOptions
 
 deriving instance Generic KoiKoi.Step
@@ -139,9 +144,76 @@ instance FromJSON Hanafuda.Flower
 instance ToJSON Hanafuda.Flower where
   toEncoding = genericToEncoding defaultOptions
 
-type PublicGame = GameBlueprint Int
+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)
 
-deriving instance Generic PublicGame
 instance FromJSON PublicGame
 instance ToJSON PublicGame where
   toEncoding = genericToEncoding defaultOptions
@@ -149,8 +221,10 @@ instance ToJSON PublicGame where
 data T =
     Relay {from :: PlayerID, message :: FromClient}
   | Welcome {room :: Room, key :: PlayerID}
-  | Update {alone :: [PlayerID], paired :: [PlayerID]}
-  | Game {game :: PublicGame, logs :: [KoiKoi.Action]}
+  | Okaeri {room :: Room}
+  | LogIn {from :: PlayerID, as :: Text}
+  | LogOut {from :: PlayerID}
+  | Game {state :: PublicGame}
   | Pong
   | Error {error :: String}
   deriving (Generic)