protocol/src/Hanafuda/Message.hs

{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hanafuda.Message (
      T(..)
    , FromClient(..)
    , 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, 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(..), IDType(..), Prefix(..))
import Hanafuda.KoiKoi (GameID, PlayerID)
import qualified Hanafuda.KoiKoi as KoiKoi (
      Action(..), Game(..), Mode(..), Move(..), Player(..), Players(..), PlayerTurn
    , Score, Scores, 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)

first :: (a -> a) -> [a] -> [a]
first _ [] = []
first f (x:xs) = f x:xs

singleLCField :: Options
singleLCField = defaultOptions {
      constructorTagModifier = (toLower `first`)
    , sumEncoding = ObjectWithSingleField
  }

deriving instance Generic KoiKoi.Move
instance FromJSON KoiKoi.Move where
  parseJSON = genericParseJSON singleLCField
instance ToJSON KoiKoi.Move where
  toEncoding = genericToEncoding singleLCField

deriving instance Generic Hanafuda.Card
instance FromJSON Hanafuda.Card
instance ToJSON Hanafuda.Card where
  toEncoding = genericToEncoding defaultOptions

data FromClient =
    Hello {name :: Text}
  | Tadaima {myID :: PlayerID, name :: Text}
  | Answer {accept :: Bool, to :: PlayerID}
  | Invitation {to :: PlayerID}
  | Play {move :: KoiKoi.Move, onGame :: PublicGame}
  | Share {gameSave :: PublicGame}
  | Sync {latestKnown :: Coordinates, to :: PlayerID}
  | Yield {onGameID :: GameID, to :: PlayerID}
  | Quit
  | Ping
  deriving (Generic, Show)

instance FromJSON FromClient
instance ToJSON FromClient where
  toEncoding = genericToEncoding defaultOptions

type Room = Map PlayerID Text

deriving instance Generic KoiKoi.Source
instance FromJSON KoiKoi.Source
instance ToJSON KoiKoi.Source where
  toEncoding = genericToEncoding defaultOptions

deriving instance Generic KoiKoi.Action
instance FromJSON KoiKoi.Action
instance ToJSON KoiKoi.Action where
  toEncoding = genericToEncoding defaultOptions

deriving instance Generic KoiKoi.Yaku
instance FromJSON KoiKoi.Yaku
instance FromJSONKey KoiKoi.Yaku where
  fromJSONKey = FromJSONKeyText (read . Text.unpack)
instance ToJSON KoiKoi.Yaku where
  toEncoding = genericToEncoding defaultOptions
instance ToJSONKey KoiKoi.Yaku where
  toJSONKey = toJSONKeyText (Text.pack . show)

deriving instance Generic KoiKoi.Player
instance FromJSON KoiKoi.Player
instance ToJSON KoiKoi.Player where
  toEncoding = genericToEncoding defaultOptions

deriving instance Generic KoiKoi.Players
instance FromJSON KoiKoi.Players
instance ToJSON KoiKoi.Players where
  toEncoding = genericToEncoding defaultOptions

deriving instance Generic KoiKoi.Step
instance FromJSON KoiKoi.Step
instance ToJSON KoiKoi.Step where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Hanafuda.Pack where
  parseJSON = fmap Hanafuda.packOfCards . parseJSON
instance ToJSON Hanafuda.Pack where
  toJSON = toJSON . Hanafuda.cardsOfPack
  toEncoding = toEncoding . Hanafuda.cardsOfPack

deriving instance Generic KoiKoi.Mode
instance FromJSON KoiKoi.Mode
instance ToJSON KoiKoi.Mode where
  toEncoding = genericToEncoding defaultOptions

deriving instance Generic Hanafuda.Flower
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)

instance FromJSON PublicGame
instance ToJSON PublicGame where
  toEncoding = genericToEncoding defaultOptions

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}
  | Pong
  | Error {error :: String}
  deriving (Generic)

instance FromJSON T
instance ToJSON T where
  toEncoding = genericToEncoding defaultOptions