server/src/Messaging.hs

77 lines
2.2 KiB
Haskell
Raw Normal View History

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Messaging (
FromClient(..)
, T(..)
, broadcast
, get
, notifyPlayers
, receive
, relay
, send
, sendTo
, update
) where
import Data.List (intercalate)
import Data.Foldable (forM_)
import Data.Map (keys)
import Data.Aeson (eitherDecode', encode)
import Network.WebSockets (receiveData, sendTextData)
import Data.ByteString.Lazy.Char8 (unpack)
import Control.Monad.Reader (asks, lift)
import qualified Game (export)
import qualified Session (T(..))
import qualified Server (T(..), get)
import qualified App (Context(..), T, connection, debug, server)
import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game, GameBlueprint(..), PlayerID)
import qualified Hanafuda.Message as Message (T)
import Hanafuda.Message (FromClient(..), T(..))
sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T ()
sendTo playerIDs obj = do
sessions <- getSessions <$> App.server
App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded
where
encoded = encode $ obj
getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs
recipients = show <$> playerIDs
send :: Message.T -> App.T ()
send obj = do
playerID <- asks App.playerID
sendTo [playerID] obj
broadcast :: Message.T -> App.T ()
broadcast obj =
App.server >>= flip sendTo obj . keys . Server.sessions
relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
relay message f = do
App.debug "Relaying"
(\from -> f $ Relay {from, message}) =<< asks App.playerID
receive :: App.T FromClient
receive = do
received <- ((lift . receiveData) =<< App.connection)
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
update :: T
update = Update {alone = [], paired = []}
notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T ()
notifyPlayers game logs =
forM_ (keys $ KoiKoi.scores game) $ \k ->
sendTo [k] $ Game {game = Game.export k game, logs}