Types.hs

{-# LANGUAGE TemplateHaskell #-}

-- | Types for shards
module Calamity.Gateway.Types (
  ShardC,
  ShardMsg (..),
  ReceivedDiscordMessage (..),
  SentDiscordMessage (..),
  DispatchType (..),
  IdentifyData (..),
  StatusUpdateData (..),
  ResumeData (..),
  RequestGuildMembersData (..),
  IdentifyProps (..),
  ControlMessage (..),
  ShardFlowControl (..),
  Shard (..),
  ShardState (..),
) where

import Calamity.Gateway.DispatchEvents
import Calamity.Gateway.Intents
import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=))
import Calamity.Metrics.Eff
import Calamity.Types.LogEff
import Calamity.Types.Model.Guild.Guild
import Calamity.Types.Model.Presence.Activity
import Calamity.Types.Model.User
import Calamity.Types.Model.Voice
import Calamity.Types.Snowflake
import Control.Concurrent.Async
import Control.Concurrent.Chan.Unagi
import Data.Aeson qualified as Aeson
import Data.Aeson.Optics
import Data.Aeson.Types (parseMaybe)
import Data.Aeson.Types qualified as AT
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics
import Network.WebSockets.Connection (Connection)
import Optics
import Polysemy qualified as P
import Polysemy.Async qualified as P
import Polysemy.AtomicState qualified as P

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

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

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

instance Aeson.FromJSON ReceivedDiscordMessage where
  parseJSON = Aeson.withObject "ReceivedDiscordMessage" $ \v -> do
    op :: Int <- v Aeson..: "op"
    case op of
      0 -> do
        d <- v Aeson..: "d"
        t <- v Aeson..: "t"
        s <- v Aeson..: "s"
        EvtDispatch s <$> parseDispatchData t d
      1 -> pure HeartBeatReq
      7 -> pure Reconnect
      9 -> InvalidSession <$> v Aeson..: "d"
      10 ->
        Hello <$> do
          d <- v Aeson..: "d"
          d Aeson..: "heartbeat_interval"
      11 -> pure HeartBeatAck
      _ -> fail $ "invalid opcode: " <> show op

parseDispatchData :: DispatchType -> Aeson.Value -> AT.Parser DispatchData
parseDispatchData READY data' = Ready <$> Aeson.parseJSON data'
parseDispatchData RESUMED _ = pure Resumed
parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> Aeson.parseJSON data'
parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> Aeson.parseJSON data'
parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> Aeson.parseJSON data'
parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> Aeson.parseJSON data'
parseDispatchData GUILD_CREATE data' = GuildCreate <$> Aeson.parseJSON data'
parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> Aeson.parseJSON data'
parseDispatchData GUILD_DELETE data' = GuildDelete <$> Aeson.parseJSON data'
parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> Aeson.parseJSON data'
parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> Aeson.parseJSON data'
parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> Aeson.parseJSON data'
parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> Aeson.parseJSON data'
parseDispatchData GUILD_MEMBER_ADD data' = do
  guildID <- Aeson.withObject "GuildMemberAdd.guild_id" (Aeson..: "guild_id") data'
  GuildMemberAdd guildID <$> Aeson.parseJSON data'
parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> Aeson.parseJSON data'
parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> Aeson.parseJSON data'
parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> Aeson.parseJSON data'
parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> Aeson.parseJSON data'
parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> Aeson.parseJSON data'
parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> Aeson.parseJSON data'
parseDispatchData INVITE_CREATE data' = InviteCreate <$> Aeson.parseJSON data'
parseDispatchData INVITE_DELETE data' = InviteDelete <$> Aeson.parseJSON data'
parseDispatchData MESSAGE_CREATE data' = do
  message <- Aeson.parseJSON data'
  let member =
        parseMaybe
          ( Aeson.withObject "MessageCreate.member" $ \o -> do
              userObject :: Aeson.Object <- o Aeson..: "author"
              memberObject :: Aeson.Object <- o Aeson..: "member"
              Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject)
          )
          data'

  let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author"
  pure $ MessageCreate message user member
parseDispatchData MESSAGE_UPDATE data' = do
  message <- Aeson.parseJSON data'
  let member =
        parseMaybe
          ( Aeson.withObject "MessageCreate.member" $ \o -> do
              userObject :: Aeson.Object <- o Aeson..: "author"
              memberObject :: Aeson.Object <- o Aeson..: "member"
              Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject)
          )
          data'
  let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author"
  pure $ MessageUpdate message user member
parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> Aeson.parseJSON data'
parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> Aeson.parseJSON data'
parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> Aeson.parseJSON data'
parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> Aeson.parseJSON data'
parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> Aeson.parseJSON data'
parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> Aeson.parseJSON data'
parseDispatchData TYPING_START data' = TypingStart <$> Aeson.parseJSON data'
parseDispatchData USER_UPDATE data' = UserUpdate <$> Aeson.parseJSON data'
parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> Aeson.parseJSON data'
parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> Aeson.parseJSON data'
parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> Aeson.parseJSON data'
parseDispatchData INTERACTION_CREATE data' = InteractionCreate <$> Aeson.parseJSON data'
parseDispatchData e _ = pure . UNHANDLED . T.pack . show $ e

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

instance Aeson.ToJSON SentDiscordMessage where
  toJSON (HeartBeat data') = Aeson.object ["op" Aeson..= (1 :: Int), "d" Aeson..= data']
  toJSON (Identify data') = Aeson.object ["op" Aeson..= (2 :: Int), "d" Aeson..= data']
  toJSON (StatusUpdate data') = Aeson.object ["op" Aeson..= (3 :: Int), "d" Aeson..= data']
  toJSON (VoiceStatusUpdate data') = Aeson.object ["op" Aeson..= (4 :: Int), "d" Aeson..= data']
  toJSON (Resume data') = Aeson.object ["op" Aeson..= (6 :: Int), "d" Aeson..= data']
  toJSON (RequestGuildMembers data') = Aeson.object ["op" Aeson..= (8 :: Int), "d" Aeson..= data']

  toEncoding (HeartBeat data') = Aeson.pairs ("op" Aeson..= (1 :: Int) <> "d" Aeson..= data')
  toEncoding (Identify data') = Aeson.pairs ("op" Aeson..= (2 :: Int) <> "d" Aeson..= data')
  toEncoding (StatusUpdate data') = Aeson.pairs ("op" Aeson..= (3 :: Int) <> "d" Aeson..= data')
  toEncoding (VoiceStatusUpdate data') = Aeson.pairs ("op" Aeson..= (4 :: Int) <> "d" Aeson..= data')
  toEncoding (Resume data') = Aeson.pairs ("op" Aeson..= (6 :: Int) <> "d" Aeson..= data')
  toEncoding (RequestGuildMembers data') = Aeson.pairs ("op" Aeson..= (8 :: Int) <> "d" Aeson..= data')

-- Thanks sbrg:
-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs
data DispatchType
  = READY
  | RESUMED
  | APPLICATION_COMMAND_PERMISSIONS_UPDATE
  | AUTO_MODERATION_RULE_CREATE
  | AUTO_MODERATION_RULE_UPDATE
  | AUTO_MODERATION_RULE_DELETE
  | AUTO_MODERATION_ACTION_EXECUTION
  | CHANNEL_CREATE
  | CHANNEL_UPDATE
  | CHANNEL_DELETE
  | CHANNEL_PINS_UPDATE
  | THREAD_CREATE
  | THREAD_UPDATE
  | THREAD_DELETE
  | THREAD_LIST_SYNC
  | THREAD_MEMBER_UPDATE
  | THREAD_MEMBERS_UPDATE
  | GUILD_CREATE
  | GUILD_UPDATE
  | GUILD_DELETE
  | GUILD_AUDIT_LOG_ENTRY_CREATE
  | GUILD_BAN_ADD
  | GUILD_BAN_REMOVE
  | GUILD_EMOJIS_UPDATE
  | GUILD_STICKERS_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
  | GUILD_SCHEDULED_EVENT_CREATE
  | GUILD_SCHEDULED_EVENT_UPDATE
  | GUILD_SCHEDULED_EVENT_DELETE
  | GUILD_SCHEDULED_EVENT_USER_ADD
  | GUILD_SCHEDULED_EVENT_USER_REMOVE
  | INTEGRATION_CREATE
  | INTEGRATION_UPDATE
  | INTEGRATION_DELETE
  | INTERACTION_CREATE
  | INVITE_CREATE
  | INVITE_DELETE
  | MESSAGE_CREATE
  | MESSAGE_UPDATE
  | MESSAGE_DELETE
  | MESSAGE_DELETE_BULK
  | MESSAGE_REACTION_ADD
  | MESSAGE_REACTION_REMOVE
  | MESSAGE_REACTION_REMOVE_ALL
  | MESSAGE_REACTION_REMOVE_EMOJI
  | PRESENCE_UPDATE
  | STAGE_INSTANCE_CREATE
  | STAGE_INSTANCE_UPDATE
  | STATE_INSTANCE_DELETE
  | TYPING_START
  | USER_UPDATE
  | VOICE_STATE_UPDATE
  | VOICE_SERVER_UPDATE
  | WEBHOOKS_UPDATE
  deriving (Show, Eq, Enum, Generic)
  deriving (Aeson.ToJSON, Aeson.FromJSON)

data IdentifyData = IdentifyData
  { token :: Text
  , properties :: IdentifyProps
  , compress :: Bool
  , largeThreshold :: Maybe Int
  , shard :: Maybe (Int, Int)
  , presence :: Maybe StatusUpdateData
  , intents :: Intents
  }
  deriving (Show)
  deriving (Aeson.ToJSON) via CalamityToJSON IdentifyData

instance CalamityToJSON' IdentifyData where
  toPairs IdentifyData {..} =
    [ "token" .= token
    , "properties" .= properties
    , "compress" .= compress
    , "large_threshold" .?= largeThreshold
    , "shard" .?= shard
    , "presence" .?= presence
    , "intents" .= intents
    ]

data StatusUpdateData = StatusUpdateData
  { since :: Maybe Integer
  , activities :: [Activity]
  , status :: StatusType
  , afk :: Bool
  }
  deriving (Show)
  deriving (Aeson.ToJSON) via CalamityToJSON StatusUpdateData

instance CalamityToJSON' StatusUpdateData where
  toPairs StatusUpdateData {..} =
    [ "since" .= since
    , "activities" .= activities
    , "status" .= status
    , "afk" .= afk
    ]

data ResumeData = ResumeData
  { token :: Text
  , sessionID :: Text
  , seq :: Int
  }
  deriving (Show)
  deriving (Aeson.ToJSON) via CalamityToJSON ResumeData

instance CalamityToJSON' ResumeData where
  toPairs ResumeData {..} =
    [ "token" .= token
    , "session_id" .= sessionID
    , "seq" .= seq
    ]

data RequestGuildMembersData = RequestGuildMembersData
  { guildID :: Snowflake Guild
  , query :: Maybe Text
  , limit :: Int
  , presences :: Maybe Bool
  , userIDs :: Maybe [Snowflake User]
  , nonce :: Maybe Text
  }
  deriving (Show)
  deriving (Aeson.ToJSON) via CalamityToJSON RequestGuildMembersData

instance CalamityToJSON' RequestGuildMembersData where
  toPairs RequestGuildMembersData {..} =
    [ "guild_id" .= guildID
    , "query" .?= query
    , "limit" .= limit
    , "presences" .?= presences
    , "user_ids" .?= userIDs
    , "nonce" .?= nonce
    ]

data IdentifyProps = IdentifyProps
  { browser :: Text
  , device :: Text
  }
  deriving (Show)
  deriving (Aeson.ToJSON) via CalamityToJSON IdentifyProps

instance CalamityToJSON' IdentifyProps where
  toPairs IdentifyProps {..} = ["$browser" .= browser, "$device" .= device]

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

data ShardFlowControl
  = ShardFlowRestart
  | ShardFlowShutDown
  deriving (Show)

data Shard = Shard
  { shardID :: Int
  , shardCount :: Int
  , gateway :: Text
  , evtIn :: InChan CalamityEvent
  , cmdOut :: OutChan ControlMessage
  , token :: Text
  , initialStatus :: Maybe StatusUpdateData
  , intents :: Intents
  }

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

$(makeFieldLabelsNoPrefix ''Shard)
$(makeFieldLabelsNoPrefix ''ShardState)