{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
module Message (
      FromClient(..)
    , T(..)
    , broadcast
    , get
    , receive
    , relay
    , send
    , sendTo
  ) where

import Data.Map (toList)
import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
import Network.WebSockets (receiveData, sendTextData)
import Data.ByteString.Lazy.Char8 (unpack)
import Control.Monad (mapM_)
import Control.Monad.Reader (asks, lift)
import qualified Player (Key, Name, Session(..))
import qualified Server (T(..))
import qualified Session (App, T(..), connection, current, debug, server)
import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
import GHC.Generics (Generic)
import Game ()

data FromClient =
    Answer {accept :: Bool}
  | Invitation {to :: Player.Key}
  | LogIn {name :: Player.Name}
  | LogOut
  | Game {move :: KoiKoi.Move}
  | 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}
  | Pong
  | Error {error :: String}
  deriving (Generic)

instance ToJSON T where
  toEncoding = genericToEncoding defaultOptions

sendTo :: (Player.Key, Player.Session) -> T -> Session.App ()
sendTo (key, session) obj = do
  Session.debug $ '(' : show key ++ ") <" ++ (unpack encoded)
  lift $ sendTextData (Player.connection session) $ encoded
  where
    encoded = encode $ obj

send :: T -> Session.App ()
send obj = do
  key <- asks Session.key
  session <- Session.current
  sendTo (key, session) obj

broadcast :: T -> Session.App ()
broadcast obj =
  (toList . Server.sessions) <$> Session.server
  >>= mapM_ (flip sendTo obj)

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

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

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