server/src/Messaging.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Messaging (
      FromClient(..)
    , T(..)
    , broadcast
    , get
    , notifyPlayers
    , receive
    , relay
    , send
    , sendTo
    , update
  ) where

import qualified App (Context(..), T, connection, debug, server)
import Control.Monad.Reader (asks, lift)
import Data.Aeson (eitherDecode', encode)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Foldable (forM_)
import Data.List (intercalate)
import Data.Map (keys)
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 qualified Game (export)
import qualified Server (T(..), get)
import qualified Session (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 -> do
    state <- Game.export k game
    sendTo [k] $ Game {state, logs}