{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Discord.Internal.Types.Channel where
import Control.Applicative (empty)
import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Default (Default, def)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Clock
import qualified Data.HashMap.Strict as HM
import qualified Data.Vector as V
import qualified Data.Text as T
import Discord.Internal.Types.Prelude
data User = User
{ userId :: UserId
, userName :: T.Text
, userDiscrim :: T.Text
, userAvatar :: Maybe T.Text
, userIsBot :: Bool
, userIsWebhook:: Bool
, userMfa :: Maybe Bool
, userVerified :: Maybe Bool
, userEmail :: Maybe T.Text
} deriving (Show, Eq, Ord)
instance FromJSON User where
parseJSON = withObject "User" $ \o ->
User <$> o .: "id"
<*> o .: "username"
<*> o .: "discriminator"
<*> o .:? "avatar"
<*> o .:? "bot" .!= False
<*> pure False
<*> o .:? "mfa_enabled"
<*> o .:? "verified"
<*> o .:? "email"
instance ToJSON User where
toJSON User{..} = object [(name,value) | (name, Just value) <-
[ ("id", toJSON <$> pure userId)
, ("username", toJSON <$> pure userName)
, ("discriminator", toJSON <$> pure userDiscrim)
, ("avatar", toJSON <$> userAvatar)
, ("bot", toJSON <$> pure userIsBot)
, ("webhook", toJSON <$> pure userIsWebhook)
, ("mfa_enabled", toJSON <$> userMfa)
, ("verified", toJSON <$> userVerified)
, ("email", toJSON <$> userEmail)
] ]
data Webhook = Webhook
{ webhookId :: WebhookId
, webhookToken :: Text
, webhookChannelId :: ChannelId
} deriving (Show, Eq, Ord)
instance FromJSON Webhook where
parseJSON = withObject "Webhook" $ \o ->
Webhook <$> o .: "id"
<*> o .: "token"
<*> o .: "channel_id"
data ConnectionObject = ConnectionObject
{ connectionObjectId :: Text
, connectionObjectName :: Text
, connectionObjectType :: Text
, connectionObjectRevoked :: Bool
, connectionObjectIntegrations :: [IntegrationId]
, connectionObjectVerified :: Bool
, connectionObjectFriendSyncOn :: Bool
, connectionObjectShownInPresenceUpdates :: Bool
, connectionObjectVisibleToOthers :: Bool
} deriving (Show, Eq, Ord)
instance FromJSON ConnectionObject where
parseJSON = withObject "ConnectionObject" $ \o -> do
integrations <- o .: "integrations"
ConnectionObject <$> o .: "id"
<*> o .: "name"
<*> o .: "type"
<*> o .: "revoked"
<*> sequence (map (.: "id") integrations)
<*> o .: "verified"
<*> o .: "friend_sync"
<*> o .: "show_activity"
<*> ( (==) (1::Int) <$> o .: "visibility")
data Channel
= ChannelText
{ channelId :: ChannelId
, channelGuild :: GuildId
, channelName :: T.Text
, channelPosition :: Integer
, channelPermissions :: [Overwrite]
, channelTopic :: T.Text
, channelLastMessage :: Maybe MessageId
}
| ChannelVoice
{ channelId :: ChannelId
, channelGuild :: GuildId
, channelName :: T.Text
, channelPosition :: Integer
, channelPermissions :: [Overwrite]
, channelBitRate :: Integer
, channelUserLimit :: Integer
}
| ChannelDirectMessage
{ channelId :: ChannelId
, channelRecipients :: [User]
, channelLastMessage :: Maybe MessageId
}
| ChannelGroupDM
{ channelId :: ChannelId
, channelRecipients :: [User]
, channelLastMessage :: Maybe MessageId
}
| ChannelGuildCategory
{ channelId :: ChannelId
, channelGuild :: GuildId
} deriving (Show, Eq, Ord)
instance FromJSON Channel where
parseJSON = withObject "Channel" $ \o -> do
type' <- (o .: "type") :: Parser Int
case type' of
0 ->
ChannelText <$> o .: "id"
<*> o .:? "guild_id" .!= 0
<*> o .: "name"
<*> o .: "position"
<*> o .: "permission_overwrites"
<*> o .:? "topic" .!= ""
<*> o .:? "last_message_id"
1 ->
ChannelDirectMessage <$> o .: "id"
<*> o .: "recipients"
<*> o .:? "last_message_id"
2 ->
ChannelVoice <$> o .: "id"
<*> o .:? "guild_id" .!= 0
<*> o .: "name"
<*> o .: "position"
<*> o .: "permission_overwrites"
<*> o .: "bitrate"
<*> o .: "user_limit"
3 ->
ChannelGroupDM <$> o .: "id"
<*> o .: "recipients"
<*> o .:? "last_message_id"
4 ->
ChannelGuildCategory <$> o .: "id"
<*> o .:? "guild_id" .!= 0
_ -> fail ("Unknown channel type:" <> show type')
instance ToJSON Channel where
toJSON ChannelText{..} = object [(name,value) | (name, Just value) <-
[ ("id", toJSON <$> pure channelId)
, ("guild_id", toJSON <$> pure channelGuild)
, ("name", toJSON <$> pure channelName)
, ("position", toJSON <$> pure channelPosition)
, ("permission_overwrites", toJSON <$> pure channelPermissions)
, ("topic", toJSON <$> pure channelTopic)
, ("last_message_id", toJSON <$> channelLastMessage)
] ]
toJSON ChannelDirectMessage{..} = object [(name,value) | (name, Just value) <-
[ ("id", toJSON <$> pure channelId)
, ("recipients", toJSON <$> pure channelRecipients)
, ("last_message_id", toJSON <$> channelLastMessage)
] ]
toJSON ChannelVoice{..} = object [(name,value) | (name, Just value) <-
[ ("id", toJSON <$> pure channelId)
, ("guild_id", toJSON <$> pure channelGuild)
, ("name", toJSON <$> pure channelName)
, ("position", toJSON <$> pure channelPosition)
, ("permission_overwrites", toJSON <$> pure channelPermissions)
, ("bitrate", toJSON <$> pure channelBitRate)
, ("user_limit", toJSON <$> pure channelUserLimit)
] ]
toJSON ChannelGroupDM{..} = object [(name,value) | (name, Just value) <-
[ ("id", toJSON <$> pure channelId)
, ("recipients", toJSON <$> pure channelRecipients)
, ("last_message_id", toJSON <$> channelLastMessage)
] ]
toJSON ChannelGuildCategory{..} = object [(name,value) | (name, Just value) <-
[ ("id", toJSON <$> pure channelId)
, ("guild_id", toJSON <$> pure channelGuild)
] ]
channelIsInGuild :: Channel -> Bool
channelIsInGuild c = case c of
ChannelGuildCategory{..} -> True
ChannelText{..} -> True
ChannelVoice{..} -> True
_ -> False
data Overwrite = Overwrite
{ overwriteId :: OverwriteId
, overwriteType :: T.Text
, overwriteAllow :: Integer
, overwriteDeny :: Integer
} deriving (Show, Eq, Ord)
instance FromJSON Overwrite where
parseJSON = withObject "Overwrite" $ \o ->
Overwrite <$> o .: "id"
<*> o .: "type"
<*> o .: "allow"
<*> o .: "deny"
instance ToJSON Overwrite where
toJSON Overwrite{..} = object
[ ("id", toJSON overwriteId)
, ("type", toJSON overwriteType)
, ("allow", toJSON overwriteAllow)
, ("deny", toJSON overwriteDeny)
]
data Message = Message
{ messageId :: MessageId
, messageChannel :: ChannelId
, messageAuthor :: User
, messageText :: Text
, messageTimestamp :: UTCTime
, messageEdited :: Maybe UTCTime
, messageTts :: Bool
, messageEveryone :: Bool
, messageMentions :: [User]
, messageMentionRoles :: [RoleId]
, messageAttachments :: [Attachment]
, messageEmbeds :: [Embed]
, messageNonce :: Maybe Nonce
, messagePinned :: Bool
, messageGuild :: Maybe GuildId
} deriving (Show, Eq, Ord)
instance FromJSON Message where
parseJSON = withObject "Message" $ \o ->
Message <$> o .: "id"
<*> o .: "channel_id"
<*> (do isW <- o .:? "webhook_id"
a <- o .: "author"
case isW :: Maybe WebhookId of
Nothing -> pure a
Just _ -> pure $ a { userIsWebhook = True })
<*> o .:? "content" .!= ""
<*> o .:? "timestamp" .!= epochTime
<*> o .:? "edited_timestamp"
<*> o .:? "tts" .!= False
<*> o .:? "mention_everyone" .!= False
<*> o .:? "mentions" .!= []
<*> o .:? "mention_roles" .!= []
<*> o .:? "attachments" .!= []
<*> o .: "embeds"
<*> o .:? "nonce"
<*> o .:? "pinned" .!= False
<*> o .:? "guild_id" .!= Nothing
data Attachment = Attachment
{ attachmentId :: Snowflake
, attachmentFilename :: T.Text
, attachmentSize :: Integer
, attachmentUrl :: T.Text
, attachmentProxy :: T.Text
, attachmentHeight :: Maybe Integer
, attachmentWidth :: Maybe Integer
} deriving (Show, Eq, Ord)
instance FromJSON Attachment where
parseJSON = withObject "Attachment" $ \o ->
Attachment <$> o .: "id"
<*> o .: "filename"
<*> o .: "size"
<*> o .: "url"
<*> o .: "proxy_url"
<*> o .:? "height"
<*> o .:? "width"
data Embed = Embed
{ embedTitle :: Maybe T.Text
, embedType :: Maybe T.Text
, embedDescription :: Maybe T.Text
, embedUrl :: Maybe T.Text
, embedTimestamp :: Maybe UTCTime
, embedColor :: Maybe Integer
, embedFields :: [SubEmbed]
} deriving (Show, Eq, Ord)
instance Default Embed where
def = Embed
{ embedTitle = Nothing
, embedType = Nothing
, embedDescription = Nothing
, embedUrl = Nothing
, embedTimestamp = Nothing
, embedColor = Nothing
, embedFields = []
}
instance FromJSON Embed where
parseJSON = withObject "Embed" $ \o ->
Embed <$> o .:? "title"
<*> o .:? "type"
<*> o .:? "description"
<*> o .:? "url"
<*> o .:? "timestamp"
<*> o .:? "color"
<*> sequence (HM.foldrWithKey to_embed [] o)
where
to_embed k (Object v) a = case k of
"footer" -> (Footer <$> v .: "text"
<*> v .:? "icon_url" .!= ""
<*> v .:? "proxy_icon_url" .!= "") : a
"image" -> (Image <$> v .: "url"
<*> v .: "proxy_url"
<*> v .: "height"
<*> v .: "width") : a
"thumbnail" -> (Thumbnail <$> v .: "url"
<*> v .: "proxy_url"
<*> v .: "height"
<*> v .: "width") : a
"video" -> (Video <$> v .: "url"
<*> v .: "height"
<*> v .: "width") : a
"provider" -> (Provider <$> v .: "name"
<*> v .:? "url" .!= "") : a
"author" -> (Author <$> v .: "name"
<*> v .:? "url" .!= ""
<*> v .:? "icon_url" .!= ""
<*> v .:? "proxy_icon_url" .!= "") : a
_ -> a
to_embed k (Array v) a = case k of
"fields" -> [Field <$> i .: "name"
<*> i .: "value"
<*> i .: "inline"
| Object i <- V.toList v] ++ a
_ -> a
to_embed _ _ a = a
instance ToJSON Embed where
toJSON (Embed {..}) = object
[ "title" .= embedTitle
, "type" .= embedType
, "description" .= embedDescription
, "url" .= embedUrl
, "timestamp" .= embedTimestamp
, "color" .= embedColor
] |> makeSubEmbeds embedFields
where
(|>) :: Value -> HM.HashMap Text Value -> Value
(|>) (Object o) hm = Object $ HM.union o hm
(|>) _ _ = error "Type mismatch"
makeSubEmbeds :: [SubEmbed] -> HM.HashMap Text Value
makeSubEmbeds = foldr embed HM.empty
embed :: SubEmbed -> HM.HashMap Text Value -> HM.HashMap Text Value
embed (Thumbnail url _ height width) =
HM.alter (\_ -> Just $ object
[ "url" .= url
, "height" .= height
, "width" .= width
]) "thumbnail"
embed (Image url _ height width) =
HM.alter (\_ -> Just $ object
[ "url" .= url
, "height" .= height
, "width" .= width
]) "image"
embed (Author name url icon _) =
HM.alter (\_ -> Just $ object
[ "name" .= name
, "url" .= url
, "icon_url" .= icon
]) "author"
embed (Footer text icon _) =
HM.alter (\_ -> Just $ object
[ "text" .= text
, "icon_url" .= icon
]) "footer"
embed (Field name value inline) =
HM.alter (\val -> case val of
Just (Array a) -> Just . Array $ V.cons (object
[ "name" .= name
, "value" .= value
, "inline" .= inline
]) a
_ -> Just $ toJSON [
object
[ "name" .= name
, "value" .= value
, "inline" .= inline
]
]
) "fields"
embed _ = id
data SubEmbed
= Thumbnail
T.Text
T.Text
Integer
Integer
| Video
T.Text
Integer
Integer
| Image
T.Text
T.Text
Integer
Integer
| Provider
T.Text
T.Text
| Author
T.Text
T.Text
T.Text
T.Text
| Footer
T.Text
T.Text
T.Text
| Field
T.Text
T.Text
Bool
deriving (Show, Eq, Ord)
newtype Nonce = Nonce T.Text
deriving (Show, Eq, Ord)
instance FromJSON Nonce where
parseJSON (String nonce) = pure $ Nonce nonce
parseJSON (Number nonce) = pure . Nonce . T.pack . show $ nonce
parseJSON _ = empty