Taking Message-related stuff out of webapp's Game and Message modules

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

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for APILanguage
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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
+