protocol/src/Hanafuda/Message.hs

{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Hanafuda.Message (
      T(..)
    , FromClient(..)
    , PlayerStatus(..)
    , PublicGame
    , Room
  ) where

import Data.Char (toLower)
import Data.Aeson (
      FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..)
    , Value, (.:), (.=), defaultOptions, eitherDecode', encode, genericParseJSON
    , genericToEncoding, object, pairs, withObject
  )
import Data.Aeson.Types (toJSONKeyText)
import Data.Map (Map)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as Text (pack, unpack)
import GHC.Generics (Generic)
import qualified Hanafuda (Card(..), Flower(..), Pack, cardsOfPack, empty, packOfCards)
import Hanafuda.Key (Key(..), getKey)
import Hanafuda.KoiKoi (PlayerKey, GameBlueprint(..))
import qualified Hanafuda.KoiKoi as KoiKoi (
    Action(..), Game(..), Mode(..), Move(..), Score, Source(..), Step(..), Yaku(..)
  )
import Hanafuda.Player (Player(..), Players(..))

deriving instance Generic PlayerKey
instance FromJSON PlayerKey
instance FromJSONKey PlayerKey where
  fromJSONKey = FromJSONKeyText (Key . read . Text.unpack)
instance ToJSON PlayerKey where
  toEncoding = genericToEncoding defaultOptions
instance ToJSONKey PlayerKey where
  toJSONKey = toJSONKeyText (Text.pack . getKey)

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 =
    Answer {accept :: Bool}
  | Invitation {to :: PlayerKey}
  | LogIn {name :: Text}
  | LogOut
  | Play {move :: KoiKoi.Move}
  | Quit
  | Ping
  deriving (Generic)

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 PlayerKey PlayerStatus

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 (Player KoiKoi.Score)
instance FromJSON (Player KoiKoi.Score)
instance ToJSON (Player KoiKoi.Score) where
  toEncoding = genericToEncoding defaultOptions

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
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

type PublicGame = GameBlueprint Int

deriving instance Generic PublicGame
instance FromJSON PublicGame
instance ToJSON PublicGame where
  toEncoding = genericToEncoding defaultOptions

data T =
    Relay {from :: PlayerKey, message :: FromClient}
  | Welcome {room :: Room, key :: PlayerKey}
  | Update {alone :: [PlayerKey], paired :: [PlayerKey]}
  | Game {game :: PublicGame, logs :: [KoiKoi.Action]}
  | Pong
  | Error {error :: String}
  deriving (Generic)

instance FromJSON T
instance ToJSON T where
  toEncoding = genericToEncoding defaultOptions