99 lines
2.7 KiB
Haskell
99 lines
2.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
module Message (
|
|
FromClient(..)
|
|
, T(..)
|
|
, broadcast
|
|
, get
|
|
, receive
|
|
, relay
|
|
, send
|
|
, sendTo
|
|
, update
|
|
) where
|
|
|
|
import Data.List (intercalate)
|
|
import Data.Foldable (forM_)
|
|
import Data.Map (toList)
|
|
import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
|
|
import Network.WebSockets (receiveData, sendTextData)
|
|
import Data.ByteString.Lazy.Char8 (unpack)
|
|
import Data.Text (Text)
|
|
import Control.Monad.Reader (asks, lift)
|
|
import qualified Player (Key)
|
|
import qualified Game (View)
|
|
import qualified Session (T(..))
|
|
import qualified Server (T(..))
|
|
import qualified App (Context(..), T, connection, current, debug, server)
|
|
import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
|
|
import GHC.Generics (Generic)
|
|
|
|
data FromClient =
|
|
Answer {accept :: Bool}
|
|
| Invitation {to :: Player.Key}
|
|
| LogIn {name :: Text}
|
|
| LogOut
|
|
| Game {move :: KoiKoi.Move}
|
|
| Ping
|
|
deriving (Generic)
|
|
|
|
instance ToJSON FromClient where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
instance FromJSON FromClient where
|
|
parseJSON = genericParseJSON defaultOptions
|
|
|
|
data T =
|
|
Relay {from :: Player.Key, message :: FromClient}
|
|
| Welcome {room :: Server.T, key :: Player.Key}
|
|
| Update {alone :: [Player.Key], paired :: [Player.Key]}
|
|
| NewGame Game.View
|
|
| Pong
|
|
| Error {error :: String}
|
|
deriving (Generic)
|
|
|
|
instance ToJSON T where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
sendTo :: [(Player.Key, Session.T)] -> T -> App.T ()
|
|
sendTo sessions obj = do
|
|
App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
|
|
lift $ forM_ connections $ flip sendTextData encoded
|
|
where
|
|
encoded = encode $ obj
|
|
(recipients, connections) = unzip [
|
|
(show key, Session.connection session) | (key, session) <- sessions
|
|
]
|
|
|
|
send :: T -> App.T ()
|
|
send obj = do
|
|
key <- asks App.key
|
|
session <- App.current
|
|
sendTo [(key, session)] obj
|
|
|
|
broadcast :: T -> App.T ()
|
|
broadcast obj =
|
|
App.server >>= flip sendTo obj . toList . Server.sessions
|
|
|
|
relay :: FromClient -> (T -> App.T ()) -> App.T ()
|
|
relay message f = do
|
|
App.debug "Relaying"
|
|
(\from -> f $ Relay {from, message}) =<< asks App.key
|
|
|
|
receive :: App.T FromClient
|
|
receive = do
|
|
received <- ((lift . receiveData) =<< App.connection)
|
|
App.debug $ '>':(unpack received)
|
|
case eitherDecode' received of
|
|
Left errorMessage -> send (Message.Error errorMessage) >> receive
|
|
Right clientMessage -> return clientMessage
|
|
|
|
get :: App.T Message.FromClient
|
|
get =
|
|
receive >>= pong
|
|
where
|
|
pong Ping = send Pong >> get
|
|
pong m = return m
|
|
|
|
update :: T
|
|
update = Update {alone = [], paired = []}
|