diff --git a/APILanguage.cabal b/APILanguage.cabal new file mode 100644 index 0000000..4decad9 --- /dev/null +++ b/APILanguage.cabal @@ -0,0 +1,31 @@ +cabal-version: >=1.10 +-- Initial package description 'APILanguage.cabal' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: APILanguage +version: 0.1.0.0 +synopsis: The language spoken by the server and clients over the websocket. +-- description: +homepage: https://git.marvid.fr/hanafuda/APILanguage +-- bug-reports: +license: BSD3 +license-file: LICENSE +author: Tissevert +maintainer: tissevert+devel@marvid.fr +-- copyright: +category: Game +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: Hanafuda.Message + --other-modules: Hanafuda.Key + -- other-extensions: + build-depends: aeson + , base >=4.12 && <4.13 + , containers + , hanafuda + , text + hs-source-dirs: src + default-language: Haskell2010 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..722f41f --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for APILanguage + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..42f34d0 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Tissevert + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tissevert nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Hanafuda/Message.hs b/src/Hanafuda/Message.hs new file mode 100644 index 0000000..2fa3f18 --- /dev/null +++ b/src/Hanafuda/Message.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Hanafuda.Message ( + ) where + +import Data.Char (toLower) +import Data.Aeson ( + FromJSON(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..) + , Value, (.=), defaultOptions, eitherDecode', encode, genericParseJSON + , genericToEncoding, object, pairs + ) +import Data.Aeson.Types (toJSONKeyText) +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.Text as Text (pack) +import GHC.Generics (Generic) +import qualified Hanafuda (Card(..)) +import Hanafuda.Key (Key(..), getKey) +import Hanafuda.KoiKoi (PlayerKey) +import qualified Hanafuda.KoiKoi as KoiKoi (Action(..), Game(..), Move(..), Source(..)) + +deriving instance Generic PlayerKey +instance FromJSON PlayerKey +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) + +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 ToJSON KoiKoi.Source + +deriving instance Generic KoiKoi.Action +instance ToJSON KoiKoi.Action + +data T = + Relay {from :: PlayerKey, message :: FromClient} + | Welcome {room :: Room, key :: PlayerKey} + | Update {alone :: [PlayerKey], paired :: [PlayerKey]} + | Game {game :: Value, logs :: [KoiKoi.Action]} + | Pong + | Error {error :: String} + deriving (Generic) + +instance ToJSON T where + toEncoding = genericToEncoding defaultOptions +