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

import Data.List (intercalate)
import Data.Foldable (forM_)
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 Data.Text (Text)
import Control.Monad.Reader (asks, lift)
import qualified Player (Key)
import qualified Game (View)
import qualified Session (T(..))
import qualified Server (T(..))
import qualified App (Context(..), T, connection, current, debug, server)
import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
import GHC.Generics (Generic)

data FromClient =
    Answer {accept :: Bool}
  | Invitation {to :: Player.Key}
  | LogIn {name :: Text}
  | 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}
  | Update {alone :: [Player.Key], paired :: [Player.Key]}
  | NewGame Game.View
  | Pong
  | Error {error :: String}
  deriving (Generic)

instance ToJSON T where
  toEncoding = genericToEncoding defaultOptions

sendTo :: [(Player.Key, Session.T)] -> T -> App.T ()
sendTo sessions obj = do
  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
  lift $ forM_ connections $ flip sendTextData encoded
  where
    encoded = encode $ obj
    (recipients, connections) = unzip [
        (show key, Session.connection session) | (key, session) <- sessions
      ]

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

broadcast :: T -> App.T ()
broadcast obj =
  App.server >>= flip sendTo obj . toList . 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 = []}