{-# OPTIONS_GHC -Wno-orphans #-}

-- | Types for shards
module Calamity.Gateway.Types where

import           Calamity.Gateway.DispatchEvents
import           Calamity.Internal.AesonThings
import           Calamity.LogEff
import           Calamity.Types.Model.Guild.Guild
import           Calamity.Types.Model.Voice
import           Calamity.Types.Snowflake

import           Control.Concurrent.Async
import           Control.Concurrent.STM.TQueue
import           Control.Concurrent.STM.TVar
import           Control.Exception
import           Control.Monad                    ( fail )

import           Data.Aeson
import qualified Data.Aeson.Types                 as AT
import           Data.Generics.Labels             ()
import           Data.Maybe
import           Data.Text.Lazy                   ( Text )

import           GHC.Generics

import           Network.WebSockets.Connection    ( Connection )

import qualified Polysemy                         as P
import qualified Polysemy.Async                   as P
import qualified Polysemy.AtomicState             as P

data ShardMsg
  = Discord ReceivedDiscordMessage
  | Control ControlMessage
  deriving ( Show, Generic )

data ReceivedDiscordMessage
  = Dispatch Int !DispatchData
  | HeartBeatReq
  | Reconnect
  | InvalidSession Bool
  | Hello Int
  | HeartBeatAck
  deriving ( Show, Generic )

instance FromJSON ReceivedDiscordMessage where
  parseJSON = withObject "ReceivedDiscordMessage" $ \v -> do
    op :: Int <- v .: "op"
    case op of
      0  -> do
        d <- v .: "d"
        t <- v .: "t"
        s <- v .: "s"
        Dispatch s <$> parseDispatchData t d

      1  -> pure HeartBeatReq

      7  -> pure Reconnect

      9  -> InvalidSession <$> v .: "d"

      10 -> Hello <$> do
        d <- v .: "d"
        d .: "heartbeat_interval"

      11 -> pure HeartBeatAck

      _  -> fail $ "invalid opcode: " <> show op

parseDispatchData :: DispatchType -> Value -> AT.Parser DispatchData
parseDispatchData READY data' = Ready <$> parseJSON data'
parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> parseJSON data'
parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> parseJSON data'
parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> parseJSON data'
parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> parseJSON data'
parseDispatchData GUILD_CREATE data' = GuildCreate <$> parseJSON data'
parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> parseJSON data'
parseDispatchData GUILD_DELETE data' = GuildDelete <$> parseJSON data'
parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> parseJSON data'
parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> parseJSON data'
parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> parseJSON data'
parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> parseJSON data'
parseDispatchData GUILD_MEMBER_ADD data' = GuildMemberAdd <$> parseJSON data'
parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> parseJSON data'
parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> parseJSON data'
parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> parseJSON data'
parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> parseJSON data'
parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> parseJSON data'
parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> parseJSON data'
parseDispatchData MESSAGE_CREATE data' = MessageCreate <$> parseJSON data'
parseDispatchData MESSAGE_UPDATE data' = MessageUpdate <$> parseJSON data'
parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data'
parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> parseJSON data'
parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> parseJSON data'
parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> parseJSON data'
parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> parseJSON data'
parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> parseJSON data'
parseDispatchData TYPING_START data' = TypingStart <$> parseJSON data'
parseDispatchData USER_UPDATE data' = UserUpdate <$> parseJSON data'
parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> parseJSON data'
parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> parseJSON data'
parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> parseJSON data'

data SentDiscordMessage
  = StatusUpdate StatusUpdateData
  | Identify IdentifyData
  | HeartBeat (Maybe Int)
  | VoiceStatusUpdate VoiceState
  | Resume ResumeData
  | RequestGuildMembers RequestGuildMembersData
  deriving ( Show, Generic )

instance ToJSON SentDiscordMessage where
  toEncoding (HeartBeat data') = pairs ("op" .= (1 :: Int) <> "d" .= data')

  toEncoding (Identify data') = pairs ("op" .= (2 :: Int) <> "d" .= data')

  toEncoding (StatusUpdate data') = pairs ("op" .= (3 :: Int) <> "d" .= data')

  toEncoding (VoiceStatusUpdate data') = pairs ("op" .= (4 :: Int) <> "d" .= data')

  toEncoding (Resume data') = pairs ("op" .= (6 :: Int) <> "d" .= data')

  toEncoding (RequestGuildMembers data') = pairs ("op" .= (8 :: Int) <> "d" .= data')

-- Thanks sbrg:
-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs
data DispatchType
  = READY
  | CHANNEL_CREATE
  | CHANNEL_UPDATE
  | CHANNEL_DELETE
  | CHANNEL_PINS_UPDATE
  | GUILD_CREATE
  | GUILD_UPDATE
  | GUILD_DELETE
  | GUILD_BAN_ADD
  | GUILD_BAN_REMOVE
  | GUILD_EMOJIS_UPDATE
  | GUILD_INTEGRATIONS_UPDATE
  | GUILD_MEMBER_ADD
  | GUILD_MEMBER_REMOVE
  | GUILD_MEMBER_UPDATE
  | GUILD_MEMBERS_CHUNK
  | GUILD_ROLE_CREATE
  | GUILD_ROLE_UPDATE
  | GUILD_ROLE_DELETE
  | MESSAGE_CREATE
  | MESSAGE_UPDATE
  | MESSAGE_DELETE
  | MESSAGE_DELETE_BULK
  | MESSAGE_REACTION_ADD
  | MESSAGE_REACTION_REMOVE
  | MESSAGE_REACTION_REMOVE_ALL
  | PRESENCE_UPDATE
  | TYPING_START
  | USER_UPDATE
  | VOICE_STATE_UPDATE
  | VOICE_SERVER_UPDATE
  | WEBHOOKS_UPDATE
  deriving ( Show, Eq, Enum, Generic )
  deriving anyclass ( ToJSON, FromJSON )

data IdentifyData = IdentifyData
  { token          :: Text
  , properties     :: IdentifyProps
  , compress       :: Bool
  , largeThreshold :: Int
  , shard          :: (Int, Int)
  , presence       :: Maybe StatusUpdateData
  }
  deriving ( Show, Generic )
  deriving ToJSON via CalamityJSON IdentifyData

data StatusUpdateData = StatusUpdateData
  { since  :: Maybe Integer
  , game   :: Maybe Value
  , status :: Text
  , afk    :: Bool
  }
  deriving ( Show, Generic )
  deriving ToJSON via CalamityJSON StatusUpdateData

data ResumeData = ResumeData
  { token     :: Text
  , sessionID :: Text
  , seq       :: Int
  }
  deriving ( Show, Generic )
  deriving ( ToJSON, FromJSON ) via CalamityJSON ResumeData

data RequestGuildMembersData = RequestGuildMembersData
  { guildID :: Snowflake Guild
  , query   :: Maybe Text
  , limit   :: Maybe Int
  }
  deriving ( Show, Generic )

instance ToJSON RequestGuildMembersData where
  toEncoding RequestGuildMembersData { guildID, query, limit } = pairs
    ("guild_id" .= guildID <> "query" .= fromMaybe "" query <> "limit" .= fromMaybe 0 limit)

data IdentifyProps = IdentifyProps
  { browser :: Text
  , device  :: Text
  }
  deriving ( Show, Generic )

instance ToJSON IdentifyProps where
  toEncoding IdentifyProps { browser, device } = pairs ("$browser" .= browser <> "$device" .= device)

data ControlMessage
  = RestartShard
  | ShutDownShard
  | SendPresence StatusUpdateData
  deriving ( Show )

data ShardException
  = ShardExcRestart
  | ShardExcShutDown
  deriving ( Show )
  deriving anyclass Exception

data Shard = Shard
  { shardID     :: Int
  , shardCount  :: Int
  , gateway     :: Text
  , evtQueue    :: TQueue DispatchMessage
  , cmdQueue    :: TQueue ControlMessage
  , shardState  :: TVar ShardState
  , token       :: Text
  }
  deriving ( Generic )

data ShardState = ShardState
  { shardS     :: Shard
  , seqNum     :: Maybe Int
  , hbThread   :: Maybe (Async (Maybe ()))
  , hbResponse :: Bool
  , wsHost     :: Maybe Text
  , sessionID  :: Maybe Text
  , wsConn     :: Maybe Connection
  }
  deriving ( Generic )

type ShardC r = (LogC r, P.Members '[P.AtomicState ShardState, P.Embed IO, P.Final IO, P.Async] r)