81 lines
2.3 KiB
Haskell
81 lines
2.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
module Message (
|
|
FromClient(..)
|
|
, T(..)
|
|
, broadcast
|
|
, receive
|
|
, relay
|
|
, send
|
|
) where
|
|
|
|
import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
|
|
import Network.WebSockets (receiveData, sendTextData)
|
|
import Data.ByteString.Lazy.Char8 (unpack)
|
|
import Control.Monad (mapM_)
|
|
import Control.Monad.Reader (lift)
|
|
import qualified Player (Login(..), Name, T(..))
|
|
import qualified Server (T(..))
|
|
import qualified Session (App, connection, debug, get, player)
|
|
import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
|
|
import GHC.Generics (Generic)
|
|
import Game ()
|
|
|
|
data FromClient =
|
|
Answer {accept :: Bool}
|
|
| Invitation {to :: Player.Name}
|
|
| LogIn {name :: Player.Name}
|
|
| 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.Name, message :: FromClient}
|
|
| Welcome {room :: Server.T}
|
|
| Pong
|
|
| Error {error :: String}
|
|
deriving (Generic)
|
|
|
|
instance ToJSON T where
|
|
toEncoding = genericToEncoding defaultOptions
|
|
|
|
sendTo :: T -> Player.T -> Session.App ()
|
|
sendTo obj player = do
|
|
Session.debug $ '(' : playerLogin ++ ") <" ++ (unpack encoded)
|
|
lift $ sendTextData (Player.connection player) $ encoded
|
|
where
|
|
encoded = encode $ obj
|
|
playerLogin = unpack $ encode $ Player.login player
|
|
|
|
send :: T -> Session.App ()
|
|
send obj =
|
|
(obj `sendTo`) =<< Session.player
|
|
|
|
broadcast :: T -> Session.App ()
|
|
broadcast obj =
|
|
Session.get Server.bySessionId
|
|
>>= mapM_ (obj `sendTo`)
|
|
|
|
relay :: FromClient -> (T -> Session.App ()) -> Session.App ()
|
|
relay message f =
|
|
Session.debug "Relaying"
|
|
>> Session.player >>= (ifLoggedIn . Player.login)
|
|
>> Session.debug "Relayed"
|
|
where
|
|
ifLoggedIn Player.Anonymous = return ()
|
|
ifLoggedIn (Player.Login from) = f $ Relay {from, message}
|
|
|
|
receive :: Session.App FromClient
|
|
receive = do
|
|
received <- ((lift . receiveData) =<< Session.connection)
|
|
Session.debug $ '>':(unpack received)
|
|
case eitherDecode' received of
|
|
Left errorMessage -> send (Message.Error errorMessage) >> receive
|
|
Right clientMessage -> return clientMessage
|