85 lines
2.6 KiB
Haskell
85 lines
2.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Messaging (
|
|
FromClient(..)
|
|
, T(..)
|
|
, broadcast
|
|
, get
|
|
, notifyPlayers
|
|
, receive
|
|
, relay
|
|
, send
|
|
, sendTo
|
|
) where
|
|
|
|
import qualified App (T, debug, get, player, session)
|
|
import Control.Monad.Reader (lift)
|
|
import Data.Aeson (eitherDecode', encode)
|
|
import Data.ByteString.Lazy.Char8 (unpack)
|
|
import Data.Foldable (forM_)
|
|
import Data.List (intercalate)
|
|
import Data.Map (elems, keys)
|
|
import Data.Maybe (maybeToList)
|
|
import qualified Data.Set as Set (fromList, member)
|
|
import qualified Game (toPublic)
|
|
import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID)
|
|
import Hanafuda.Message (FromClient(..), T(..))
|
|
import qualified Hanafuda.Message as Message (T)
|
|
import Network.WebSockets (receiveData, sendTextData)
|
|
import Player (playerID, showDebug)
|
|
import qualified Server (sessionsWhere)
|
|
import qualified Session (T(..))
|
|
|
|
sendToSessions :: [Session.T] -> Message.T -> App.T ()
|
|
sendToSessions sessions obj = do
|
|
App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
|
|
lift . mapM_ (flip sendTextData encoded) $ Session.connection <$> sessions
|
|
where
|
|
encoded = encode $ obj
|
|
recipients = fmap showDebug . maybeToList . Session.player =<< sessions
|
|
|
|
sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T ()
|
|
sendTo playerIDs obj = do
|
|
sessions <- App.get $ Server.sessionsWhere selectedPlayer
|
|
sendToSessions (foldl (++) [] sessions) obj
|
|
where
|
|
selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs
|
|
|
|
send :: Message.T -> App.T ()
|
|
send obj = do
|
|
currentSession <- App.session
|
|
sendToSessions [currentSession] obj
|
|
|
|
broadcast :: Message.T -> App.T ()
|
|
broadcast obj = do
|
|
App.get (concat . elems . allSessions) >>= flip sendToSessions obj
|
|
where
|
|
allSessions = Server.sessionsWhere (\_ _ -> True)
|
|
|
|
relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
|
|
relay message f = do
|
|
App.debug "Relaying"
|
|
maybe (return ()) doRelay =<< App.player
|
|
where
|
|
doRelay player = f $ Relay {from = playerID player, message}
|
|
|
|
receive :: App.T FromClient
|
|
receive = do
|
|
received <- ((lift . receiveData . Session.connection) =<< App.session)
|
|
App.debug $ '>':(unpack received)
|
|
case eitherDecode' received of
|
|
Left errorMessage -> send (Error errorMessage) >> receive
|
|
Right clientMessage -> return clientMessage
|
|
|
|
get :: App.T FromClient
|
|
get =
|
|
receive >>= pong
|
|
where
|
|
pong Ping = send Pong >> get
|
|
pong m = return m
|
|
|
|
notifyPlayers :: (KoiKoi.Game, [KoiKoi.Action]) -> App.T ()
|
|
notifyPlayers (game, logs) =
|
|
forM_ (keys $ KoiKoi.nextPlayer game) $ \k ->
|
|
sendTo [k] . Game =<< Game.toPublic k game logs
|