server/src/Messaging.hs

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, 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 (exportGame)
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 (T(..), 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 (elems 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 (elems . Server.sessions) >>= flip sendToSessions obj
relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
relay message f = do
App.debug "Relaying"
maybe bounce doRelay . Session.player =<< App.session
where
doRelay player = f $ Relay {from = playerID player, message}
bounce = send (Error "Unidentified client can't relay messages")
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.scores game) $ \k -> do
state <- Game.exportGame k game
sendTo [k] $ Game {state, logs}