Compare commits
27 commits
main
...
stateless-
Author | SHA1 | Date | |
---|---|---|---|
e2019e2d3b | |||
59c467e988 | |||
4c404df4d6 | |||
509a5c453f | |||
413d6cfc84 | |||
1dd31d7091 | |||
c6352a9669 | |||
b62dc4ff28 | |||
d32e61f927 | |||
ce31683fee | |||
f968c41d9d | |||
57370d62ee | |||
775abd3ac4 | |||
9c5c80fb3a | |||
816ecbc331 | |||
43b0200304 | |||
8538b8f5ea | |||
e10afdfac1 | |||
189e29b08c | |||
818c343e89 | |||
0c2974b055 | |||
5cccd05290 | |||
e11a899745 | |||
9cfcd691fd | |||
c4edae9781 | |||
65a7c26b5a | |||
2f7be7df2b |
2 changed files with 119 additions and 43 deletions
|
@ -23,6 +23,8 @@ library
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base >=4.9 && <4.13
|
, base >=4.9 && <4.13
|
||||||
|
, base64-bytestring
|
||||||
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, hanafuda >= 0.3.3
|
, hanafuda >= 0.3.3
|
||||||
, text
|
, text
|
||||||
|
|
|
@ -3,42 +3,56 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Hanafuda.Message (
|
module Hanafuda.Message (
|
||||||
T(..)
|
T(..)
|
||||||
, FromClient(..)
|
, FromClient(..)
|
||||||
, PlayerStatus(..)
|
, Coordinates(..)
|
||||||
, PublicGame
|
, PrivateState(..)
|
||||||
|
, PublicGame(..)
|
||||||
|
, PublicPlayer(..)
|
||||||
|
, PublicState(..)
|
||||||
, Room
|
, Room
|
||||||
|
, orderCoordinates
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Char (toLower)
|
import Data.Char (toLower)
|
||||||
import Data.Aeson (
|
import Data.Aeson (
|
||||||
FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..)
|
FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..)
|
||||||
, Value, (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
|
, Value(..), (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
|
||||||
, genericToEncoding, object, pairs, withObject
|
, genericToEncoding, object, pairs, withObject, withText
|
||||||
)
|
)
|
||||||
import Data.Aeson.Types (toJSONKeyText)
|
import Data.Aeson.Types (toJSONKeyText)
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import qualified Data.ByteString.Base64 as B64 (decode, encode)
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import Data.Monoid ((<>))
|
import Data.Monoid ((<>))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as Text (pack, unpack)
|
import qualified Data.Text as Text (pack, unpack)
|
||||||
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import qualified Hanafuda (Card(..), Flower(..), Pack, cardsOfPack, empty, packOfCards)
|
import qualified Hanafuda (Card(..), Flower(..), Pack, cardsOfPack, empty, packOfCards)
|
||||||
import Hanafuda.ID (ID(..), getID)
|
import Hanafuda.ID (ID(..), IDType(..), Prefix(..))
|
||||||
import Hanafuda.KoiKoi (PlayerID, GameBlueprint(..))
|
import Hanafuda.KoiKoi (GameID, PlayerID)
|
||||||
import qualified Hanafuda.KoiKoi as KoiKoi (
|
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 Hanafuda.Player (Player(..), Players(..))
|
||||||
|
import Text.Read (readMaybe)
|
||||||
|
|
||||||
deriving instance Generic PlayerID
|
instance IDType a => FromJSON (ID a) where
|
||||||
instance FromJSON PlayerID
|
parseJSON = withText decoding (safeRead . Text.unpack)
|
||||||
instance FromJSONKey PlayerID where
|
where
|
||||||
fromJSONKey = FromJSONKeyText (ID . read . Text.unpack)
|
decoding = let Prefix p = (prefix :: Prefix a) in p ++ "ID"
|
||||||
instance ToJSON PlayerID where
|
safeRead s = maybe (fail $ "Not an ID: '" ++ s ++ "'") return $ readMaybe s
|
||||||
toEncoding = genericToEncoding defaultOptions
|
instance IDType a => FromJSONKey (ID a) where
|
||||||
instance ToJSONKey PlayerID where
|
fromJSONKey = FromJSONKeyText (read . Text.unpack)
|
||||||
toJSONKey = toJSONKeyText (Text.pack . getID)
|
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 :: (a -> a) -> [a] -> [a]
|
||||||
first _ [] = []
|
first _ [] = []
|
||||||
|
@ -62,32 +76,23 @@ instance ToJSON Hanafuda.Card where
|
||||||
toEncoding = genericToEncoding defaultOptions
|
toEncoding = genericToEncoding defaultOptions
|
||||||
|
|
||||||
data FromClient =
|
data FromClient =
|
||||||
Answer {accept :: Bool}
|
Hello {name :: Text}
|
||||||
|
| Tadaima {myID :: PlayerID, name :: Text}
|
||||||
|
| Answer {accept :: Bool, to :: PlayerID}
|
||||||
| Invitation {to :: PlayerID}
|
| Invitation {to :: PlayerID}
|
||||||
| LogIn {name :: Text}
|
| Play {move :: KoiKoi.Move, onGame :: PublicGame}
|
||||||
| LogOut
|
| Share {gameSave :: PublicGame}
|
||||||
| Play {move :: KoiKoi.Move}
|
| Sync {latestKnown :: Coordinates, to :: PlayerID}
|
||||||
|
| Yield {onGameID :: GameID, to :: PlayerID}
|
||||||
| Quit
|
| Quit
|
||||||
| Ping
|
| Ping
|
||||||
deriving (Generic)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
instance FromJSON FromClient
|
instance FromJSON FromClient
|
||||||
instance ToJSON FromClient where
|
instance ToJSON FromClient where
|
||||||
toEncoding = genericToEncoding defaultOptions
|
toEncoding = genericToEncoding defaultOptions
|
||||||
|
|
||||||
newtype PlayerStatus = PlayerStatus (Text, Bool) deriving (Generic, Show)
|
type Room = Map PlayerID Text
|
||||||
|
|
||||||
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
|
deriving instance Generic KoiKoi.Source
|
||||||
instance FromJSON KoiKoi.Source
|
instance FromJSON KoiKoi.Source
|
||||||
|
@ -108,14 +113,14 @@ instance ToJSON KoiKoi.Yaku where
|
||||||
instance ToJSONKey KoiKoi.Yaku where
|
instance ToJSONKey KoiKoi.Yaku where
|
||||||
toJSONKey = toJSONKeyText (Text.pack . show)
|
toJSONKey = toJSONKeyText (Text.pack . show)
|
||||||
|
|
||||||
deriving instance Generic (Player KoiKoi.Score)
|
deriving instance Generic KoiKoi.Player
|
||||||
instance FromJSON (Player KoiKoi.Score)
|
instance FromJSON KoiKoi.Player
|
||||||
instance ToJSON (Player KoiKoi.Score) where
|
instance ToJSON KoiKoi.Player where
|
||||||
toEncoding = genericToEncoding defaultOptions
|
toEncoding = genericToEncoding defaultOptions
|
||||||
|
|
||||||
deriving instance Generic (Players KoiKoi.Score)
|
deriving instance Generic KoiKoi.Players
|
||||||
instance FromJSON (Players KoiKoi.Score)
|
instance FromJSON KoiKoi.Players
|
||||||
instance ToJSON (Players KoiKoi.Score) where
|
instance ToJSON KoiKoi.Players where
|
||||||
toEncoding = genericToEncoding defaultOptions
|
toEncoding = genericToEncoding defaultOptions
|
||||||
|
|
||||||
deriving instance Generic KoiKoi.Step
|
deriving instance Generic KoiKoi.Step
|
||||||
|
@ -139,9 +144,76 @@ instance FromJSON Hanafuda.Flower
|
||||||
instance ToJSON Hanafuda.Flower where
|
instance ToJSON Hanafuda.Flower where
|
||||||
toEncoding = genericToEncoding defaultOptions
|
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 FromJSON PublicGame
|
||||||
instance ToJSON PublicGame where
|
instance ToJSON PublicGame where
|
||||||
toEncoding = genericToEncoding defaultOptions
|
toEncoding = genericToEncoding defaultOptions
|
||||||
|
@ -149,8 +221,10 @@ instance ToJSON PublicGame where
|
||||||
data T =
|
data T =
|
||||||
Relay {from :: PlayerID, message :: FromClient}
|
Relay {from :: PlayerID, message :: FromClient}
|
||||||
| Welcome {room :: Room, key :: PlayerID}
|
| Welcome {room :: Room, key :: PlayerID}
|
||||||
| Update {alone :: [PlayerID], paired :: [PlayerID]}
|
| Okaeri {room :: Room}
|
||||||
| Game {game :: PublicGame, logs :: [KoiKoi.Action]}
|
| LogIn {from :: PlayerID, as :: Text}
|
||||||
|
| LogOut {from :: PlayerID}
|
||||||
|
| Game {state :: PublicGame}
|
||||||
| Pong
|
| Pong
|
||||||
| Error {error :: String}
|
| Error {error :: String}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
Loading…
Reference in a new issue