server/src/Message.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
module Message (
      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 (FromJSON(..), ToJSON(..), Value, eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
import Network.WebSockets (receiveData, sendTextData)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Text (Text)
import Control.Monad.Reader (asks, lift)
import qualified Player (Key)
import qualified Game (T, 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(..), Move(..))
import GHC.Generics (Generic)

data FromClient =
    Answer {accept :: Bool}
  | Invitation {to :: Player.Key}
  | LogIn {name :: Text}
  | LogOut
  | Play {move :: KoiKoi.Move}
  | Quit
  | Ping
  deriving (Generic)

instance ToJSON FromClient where
  toEncoding = genericToEncoding defaultOptions
instance FromJSON FromClient where
  parseJSON = genericParseJSON defaultOptions

data T =
    Relay {from :: Player.Key, message :: FromClient}
  | Welcome {room :: Server.T, key :: Player.Key}
  | Update {alone :: [Player.Key], paired :: [Player.Key]}
  | Game {game :: Value, logs :: [KoiKoi.Action]}
  | Pong
  | Error {error :: String}
  deriving (Generic)

instance ToJSON T where
  toEncoding = genericToEncoding defaultOptions

sendTo :: [Player.Key] -> T -> App.T ()
sendTo playerKeys 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 = (\key -> Server.get key server) <$> playerKeys
    recipients = show <$> playerKeys

send :: T -> App.T ()
send obj = do
  key <- asks App.key
  sendTo [key] obj

broadcast :: T -> App.T ()
broadcast obj =
  App.server >>= flip sendTo obj . keys . Server.sessions

relay :: FromClient -> (T -> App.T ()) -> App.T ()
relay message f = do
  App.debug "Relaying"
  (\from -> f $ Relay {from, message}) =<< asks App.key

receive :: App.T FromClient
receive = do
  received <- ((lift . receiveData) =<< App.connection)
  App.debug $ '>':(unpack received)
  case eitherDecode' received of
    Left errorMessage -> send (Message.Error errorMessage) >> receive
    Right clientMessage -> return clientMessage

get :: App.T Message.FromClient
get =
  receive >>= pong
  where
    pong Ping = send Pong >> get
    pong m = return m

update :: T
update = Update {alone = [], paired = []}

notifyPlayers :: Game.T -> [KoiKoi.Action] -> App.T ()
notifyPlayers game logs =
  forM_ (keys $ KoiKoi.scores game) $ \k ->
    sendTo [k] $ Game {game = Game.export k game, logs}