Guild.hs

{-# LANGUAGE TemplateHaskell #-}

-- | Discord Guilds
module Calamity.Types.Model.Guild.Guild (
  Guild (..),
  GuildIcon (..),
  GuildSplash (..),
  GuildDiscoverySplash (..),
  GuildBanner (..),
  Partial (PartialGuild),
  UpdatedGuild (..),
) where

import Calamity.Internal.SnowflakeMap (SnowflakeMap)
import Calamity.Internal.SnowflakeMap qualified as SM
import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=))
import Calamity.Types.CDNAsset (CDNAsset (..))
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild.Emoji
import Calamity.Types.Model.Guild.Member
import Calamity.Types.Model.Guild.Role
import Calamity.Types.Model.Presence.Presence
import Calamity.Types.Model.User
import Calamity.Types.Model.Voice.VoiceState
import Calamity.Types.Snowflake
import Calamity.Utils.CDNUrl (assetHashFile, cdnURL)
import Data.Aeson ((.!=), (.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as LH
import Data.Maybe
import Data.Text qualified as T
import Data.Time
import Data.Word
import Network.HTTP.Req ((/:), (/~))
import Optics
import TextShow qualified
import TextShow.TH (deriveTextShow)

data GuildIcon = GuildIcon
  { guildID :: Snowflake Guild
  , hash :: T.Text
  }
  deriving (Show, Eq)

instance CDNAsset GuildIcon where
  assetURL GuildIcon {hash, guildID} =
    cdnURL /: "icons" /~ guildID /: assetHashFile hash

data GuildSplash = GuildSplash
  { guildID :: Snowflake Guild
  , hash :: T.Text
  }
  deriving (Show, Eq)

instance CDNAsset GuildSplash where
  assetURL GuildSplash {hash, guildID} =
    cdnURL /: "splashes" /~ guildID /: assetHashFile hash

data GuildDiscoverySplash = GuildDiscoverySplash
  { guildID :: Snowflake Guild
  , hash :: T.Text
  }
  deriving (Show, Eq)

instance CDNAsset GuildDiscoverySplash where
  assetURL GuildDiscoverySplash {hash, guildID} =
    cdnURL /: "discovery-splashes" /~ guildID /: assetHashFile hash

data GuildBanner = GuildBanner
  { guildID :: Snowflake Guild
  , hash :: T.Text
  }
  deriving (Show, Eq)

instance CDNAsset GuildBanner where
  assetURL GuildBanner {hash, guildID} =
    cdnURL /: "banners" /~ guildID /: assetHashFile hash

data Guild = Guild
  { id :: Snowflake Guild
  , name :: T.Text
  , icon :: Maybe GuildIcon
  , splash :: Maybe GuildSplash
  , discoverySplash :: Maybe GuildSplash
  , banner :: Maybe GuildBanner
  , owner :: Maybe Bool
  , ownerID :: Snowflake User
  , permissions :: Word64
  , afkChannelID :: Maybe (Snowflake GuildChannel)
  , afkTimeout :: Int
  , embedEnabled :: Bool
  , embedChannelID :: Maybe (Snowflake GuildChannel)
  , verificationLevel :: Int
  , defaultMessageNotifications :: Int
  , explicitContentFilter :: Int
  , roles :: SnowflakeMap Role
  , emojis :: SnowflakeMap Emoji
  , features :: [T.Text]
  , mfaLevel :: Int
  , applicationID :: Maybe (Snowflake User)
  , widgetEnabled :: Bool
  , widgetChannelID :: Maybe (Snowflake GuildChannel)
  , systemChannelID :: Maybe (Snowflake GuildChannel)
  , -- NOTE: Below are only sent on GuildCreate
    joinedAt :: Maybe UTCTime
  , large :: Bool
  , unavailable :: Bool
  , memberCount :: Int
  , voiceStates :: [VoiceState]
  , members :: SnowflakeMap Member
  , channels :: SnowflakeMap GuildChannel
  , presences :: HashMap (Snowflake User) Presence
  , preferredLocale :: T.Text
  }
  deriving (Eq, Show)
  deriving (TextShow.TextShow) via TextShow.FromStringShow Guild
  deriving (HasID Guild) via HasIDField "id" Guild

instance Aeson.FromJSON Guild where
  parseJSON = Aeson.withObject "Guild" $ \v -> do
    id <- v .: "id"

    members' <- do
      members' <- v .: "members"
      pure . SM.fromList . mapMaybe (Aeson.parseMaybe @Aeson.Object @Member (Aeson.parseJSON . Aeson.Object)) $ members'

    channels' <- do
      channels' <- v .: "channels"
      SM.fromList <$> traverse (\c -> Aeson.parseJSON $ Aeson.Object (c <> "guild_id" Aeson..= id)) channels'

    presences' <- do
      presences' <- v .: "presences"
      pure
        . LH.fromList
        . mapMaybe
          ( Aeson.parseMaybe @Aeson.Object @(Snowflake User, Presence)
              ( \m -> do
                  p <- Aeson.parseJSON $ Aeson.Object (m <> "guild_id" Aeson..= id)
                  pure (getID $ p ^. labelOptic @"user", p)
              )
          )
        $ presences'

    icon <- (GuildIcon id <$>) <$> v .:? "icon"
    splash <- (GuildSplash id <$>) <$> v .:? "splash"
    discoverySplash <- (GuildSplash id <$>) <$> v .:? "discovery_splash"
    banner <- (GuildBanner id <$>) <$> v .:? "banner"

    Guild id
      <$> v .: "name"
      <*> pure icon
      <*> pure splash
      <*> pure discoverySplash
      <*> pure banner
      <*> v .:? "owner"
      <*> v .: "owner_id"
      <*> v .:? "permissions" .!= 0
      <*> v .:? "afk_channel_id"
      <*> v .: "afk_timeout"
      <*> v .:? "embed_enabled" .!= False
      <*> v .:? "embed_channel_id"
      <*> v .: "verification_level"
      <*> v .: "default_message_notifications"
      <*> v .: "explicit_content_filter"
      <*> v .: "roles"
      <*> v .: "emojis"
      <*> v .: "features"
      <*> v .: "mfa_level"
      <*> v .:? "application_id"
      <*> v .:? "widget_enabled" .!= False
      <*> v .:? "widget_channel_id"
      <*> v .:? "system_channel_id"
      <*> v .:? "joined_at"
      <*> v .: "large"
      <*> v .:? "unavailable" .!= False
      <*> v .: "member_count"
      <*> v .: "voice_states"
      <*> pure members'
      <*> pure channels'
      <*> pure presences'
      <*> v .: "preferred_locale"

data instance Partial Guild = PartialGuild
  { id :: Snowflake Guild
  , name :: T.Text
  }
  deriving (Eq, Show)
  deriving (HasID Guild) via HasIDField "id" (Partial Guild)
  deriving (Aeson.ToJSON) via CalamityToJSON (Partial Guild)

instance CalamityToJSON' (Partial Guild) where
  toPairs PartialGuild {..} =
    [ "id" .= id
    , "name" .= name
    ]

instance Aeson.FromJSON (Partial Guild) where
  parseJSON = Aeson.withObject "Partial Guild" $ \v ->
    PartialGuild
      <$> v .: "id"
      <*> v .: "name"

data UpdatedGuild = UpdatedGuild
  { id :: Snowflake Guild
  , name :: T.Text
  , icon :: Maybe GuildIcon
  , splash :: Maybe GuildSplash
  , discoverySplash :: Maybe GuildSplash
  , banner :: Maybe GuildBanner
  , owner :: Maybe Bool
  , ownerID :: Snowflake User
  , permissions :: Maybe Word64
  , afkChannelID :: Maybe (Snowflake GuildChannel)
  , afkTimeout :: Int
  , embedEnabled :: Maybe Bool
  , embedChannelID :: Maybe (Snowflake GuildChannel)
  , verificationLevel :: Int
  , defaultMessageNotifications :: Int
  , explicitContentFilter :: Int
  , roles :: SnowflakeMap Role
  , emojis :: SnowflakeMap Emoji
  , features :: [T.Text]
  , mfaLevel :: Int
  , applicationID :: Maybe (Snowflake User)
  , widgetEnabled :: Maybe Bool
  , widgetChannelID :: Maybe (Snowflake GuildChannel)
  , systemChannelID :: Maybe (Snowflake GuildChannel)
  , preferredLocale :: T.Text
  }
  deriving (Eq, Show)
  deriving (TextShow.TextShow) via TextShow.FromStringShow UpdatedGuild
  deriving (HasID Guild) via HasIDField "id" UpdatedGuild

instance Aeson.FromJSON UpdatedGuild where
  parseJSON = Aeson.withObject "Guild" $ \v -> do
    id <- v .: "id"
    icon <- (GuildIcon id <$>) <$> v .:? "icon"
    splash <- (GuildSplash id <$>) <$> v .:? "splash"
    discoverySplash <- (GuildSplash id <$>) <$> v .:? "discovery_splash"
    banner <- (GuildBanner id <$>) <$> v .:? "banner"

    UpdatedGuild
      <$> v .: "id"
      <*> v .: "name"
      <*> pure icon
      <*> pure splash
      <*> pure discoverySplash
      <*> pure banner
      <*> v .:? "owner"
      <*> v .: "owner_id"
      <*> v .:? "permissions"
      <*> v .:? "afk_channel_id"
      <*> v .: "afk_timeout"
      <*> v .:? "embed_enabled"
      <*> v .:? "embed_channel_id"
      <*> v .: "verification_level"
      <*> v .: "default_message_notifications"
      <*> v .: "explicit_content_filter"
      <*> v .: "roles"
      <*> v .: "emojis"
      <*> v .: "features"
      <*> v .: "mfa_level"
      <*> v .:? "application_id"
      <*> v .:? "widget_enabled"
      <*> v .:? "widget_channel_id"
      <*> v .:? "system_channel_id"
      <*> v .: "preferred_locale"

$(deriveTextShow ''GuildIcon)
$(deriveTextShow 'PartialGuild)

$(makeFieldLabelsNoPrefix ''Guild)
$(makeFieldLabelsNoPrefix ''GuildIcon)
$(makeFieldLabelsNoPrefix 'PartialGuild)
$(makeFieldLabelsNoPrefix ''UpdatedGuild)