diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Joshua Koike + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/discord-types.cabal b/discord-types.cabal new file mode 100644 --- /dev/null +++ b/discord-types.cabal @@ -0,0 +1,40 @@ +name: discord-types +version: 0.2.2 +synopsis: Type information for discord-hs +description: Type information for discord-hs +homepage: https://github.com/jano017/Discord.hs +license: MIT +license-file: LICENSE +author: Joshua Koike +maintainer: jkoike2013@gmail.com +category: Network +build-type: Simple +cabal-version: >=1.10 + +Flag disable-docs + Description: Disable documentation generation + Manual: True + Default: False + +library + exposed-modules: Network.Discord.Types + , Network.Discord.Types.Channel + , Network.Discord.Types.Guild + , Network.Discord.Types.Events + , Network.Discord.Types.Gateway + other-modules: Network.Discord.Types.Prelude + build-depends: base==4.* + , aeson>=1.0 && <1.2 + , text==1.2.* + , time>=1.6 && <1.9 + , hashable==1.2.* + , vector>=0.10 && <0.13 + , unordered-containers==0.2.* + , transformers==0.5.* + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + +source-repository head + type : git + location: https://github.com/jano017/Discord.hs diff --git a/src/Network/Discord/Types.hs b/src/Network/Discord/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE RankNTypes, ExistentialQuantification, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_HADDOCK prune, not-home #-} +-- | Provides types and encoding/decoding code. Types should be identical to those provided +-- in the Discord API documentation. +module Network.Discord.Types + ( module Network.Discord.Types + , module Network.Discord.Types.Prelude + , module Network.Discord.Types.Channel + , module Network.Discord.Types.Events + , module Network.Discord.Types.Gateway + , module Network.Discord.Types.Guild + , module Data.Aeson + ) where + import Control.Monad (MonadPlus) + + import Network.Discord.Types.Channel + import Network.Discord.Types.Events + import Network.Discord.Types.Gateway + import Network.Discord.Types.Guild + import Network.Discord.Types.Prelude + + import Control.Monad.IO.Class + import Data.Aeson (Object) + + class (MonadIO m, MonadPlus m) => DiscordAuth m where + auth :: m Auth + version :: m String + runIO :: m a -> IO a diff --git a/src/Network/Discord/Types/Channel.hs b/src/Network/Discord/Types/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Channel.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE OverloadedStrings, MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +-- | Data structures pertaining to Discord Channels +module Network.Discord.Types.Channel where + import Control.Monad (mzero) + import Data.Text as Text (pack, Text) + + import Data.Aeson + import Data.Aeson.Types (Parser) + import Data.Time.Clock + import Data.Vector (toList) + import qualified Data.HashMap.Strict as HM + import qualified Data.Vector as V + + import Network.Discord.Types.Prelude + + -- |Represents information about a user. + data User = User + { userId :: {-# UNPACK #-} !Snowflake -- ^ The user's id. + , userName :: String -- ^ The user's username, not unique across + -- the platform. + , userDiscrim :: String -- ^ The user's 4-digit discord-tag. + , userAvatar :: Maybe String -- ^ The user's avatar hash. + , userIsBot :: Bool -- ^ Whether the user belongs to an OAuth2 + -- application. + , userMfa :: Maybe Bool -- ^ Whether the user has two factor + -- authentication enabled on the account. + , userVerified :: Maybe Bool -- ^ Whether the email on this account has + -- been verified. + , userEmail :: Maybe String -- ^ The user's email. + } + | Webhook deriving (Show, Eq) + + instance FromJSON User where + parseJSON (Object o) = + User <$> o .: "id" + <*> o .: "username" + <*> o .: "discriminator" + <*> o .:? "avatar" + <*> o .:? "bot" .!= False + <*> o .:? "mfa_enabled" + <*> o .:? "verified" + <*> o .:? "email" + parseJSON _ = mzero + + -- | Guild channels represent an isolated set of users and messages in a Guild (Server) + data Channel + -- | A text channel in a guild. + = Text + { channelId :: Snowflake -- ^ The id of the channel (Will be equal to + -- the guild if it's the "general" channel). + , channelGuild :: Snowflake -- ^ The id of the guild. + , channelName :: String -- ^ The name of the guild (2 - 1000 characters). + , channelPosition :: Integer -- ^ The storing position of the channel. + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's + , channelTopic :: String -- ^ The topic of the channel. (0 - 1024 chars). + , channelLastMessage :: Snowflake -- ^ The id of the last message sent in the + -- channel + } + -- |A voice channel in a guild. + | Voice + { channelId:: Snowflake + , channelGuild:: Snowflake + , channelName:: String + , channelPosition:: Integer + , channelPermissions:: [Overwrite] + , channelBitRate:: Integer -- ^ The bitrate (in bits) of the channel. + , channelUserLimit:: Integer -- ^ The user limit of the voice channel. + } + -- | DM Channels represent a one-to-one conversation between two users, outside the scope + -- of guilds + | DirectMessage + { channelId :: Snowflake + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). + , channelLastMessage :: Snowflake + } deriving (Show, Eq) + + instance FromJSON Channel where + parseJSON = withObject "text or voice" $ \o -> do + type' <- (o .: "type") :: Parser Int + case type' of + 0 -> + Text <$> o .: "id" + <*> o .: "guild_id" + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" .!= 0 + 1 -> + DirectMessage <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" .!= 0 + 2 -> + Voice <$> o .: "id" + <*> o .: "guild_id" + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .: "bitrate" + <*> o .: "user_limit" + _ -> mzero + + -- | Permission overwrites for a channel. + data Overwrite = Overwrite + { overwriteId:: {-# UNPACK #-} !Snowflake -- ^ 'Role' or 'User' id + , overWriteType:: String -- ^ Either "role" or "member + , overwriteAllow:: Integer -- ^ Allowed permission bit set + , overwriteDeny:: Integer -- ^ Denied permission bit set + } deriving (Show, Eq) + + instance FromJSON Overwrite where + parseJSON (Object o) = + Overwrite <$> o .: "id" + <*> o .: "type" + <*> o .: "allow" + <*> o .: "deny" + parseJSON _ = mzero + + -- | Represents information about a message in a Discord channel. + data Message = Message + { messageId :: {-# UNPACK #-} !Snowflake -- ^ The id of the message + , messageChannel :: {-# UNPACK #-} !Snowflake -- ^ Id of the channel the message + -- was sent in + , messageAuthor :: User -- ^ The 'User' the message was sent + -- by + , messageContent :: Text -- ^ Contents of the message + , messageTimestamp :: UTCTime -- ^ When the message was sent + , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited + , messageTts :: Bool -- ^ Whether this message was a TTS + -- message + , messageEveryone :: Bool -- ^ Whether this message mentions + -- everyone + , messageMentions :: [User] -- ^ 'User's specifically mentioned in + -- the message + , messageMentionRoles :: [Snowflake] -- ^ 'Role's specifically mentioned in + -- the message + , messageAttachments :: [Attachment] -- ^ Any attached files + , messageEmbeds :: [Embed] -- ^ Any embedded content + , messageNonce :: Maybe Snowflake -- ^ Used for validating if a message + -- was sent + , messagePinned :: Bool -- ^ Whether this message is pinned + } deriving (Show, Eq) + + instance FromJSON Message where + parseJSON (Object o) = + Message <$> o .: "id" + <*> o .: "channel_id" + <*> o .:? "author" .!= Webhook + <*> 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 + parseJSON _ = mzero + + -- |Represents an attached to a message file. + data Attachment = Attachment + { attachmentId :: {-# UNPACK #-} !Snowflake -- ^ Attachment id + , attachmentFilename :: String -- ^ Name of attached file + , attachmentSize :: Integer -- ^ Size of file (in bytes) + , attachmentUrl :: String -- ^ Source of file + , attachmentProxy :: String -- ^ Proxied url of file + , attachmentHeight :: Maybe Integer -- ^ Height of file (if image) + , attachmentWidth :: Maybe Integer -- ^ Width of file (if image) + } deriving (Show, Eq) + + instance FromJSON Attachment where + parseJSON (Object o) = + Attachment <$> o .: "id" + <*> o .: "filename" + <*> o .: "size" + <*> o .: "url" + <*> o .: "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + parseJSON _ = mzero + + -- |An embed attached to a message. + data Embed = Embed + { embedTitle :: String -- ^ Title of the embed + , embedType :: String -- ^ Type of embed (Always "rich" for webhooks) + , embedDesc :: String -- ^ Description of embed + , embedUrl :: String -- ^ URL of embed + , embedTime :: UTCTime -- ^ The time of the embed content + , embedColor :: Integer -- ^ The embed color + , embedFields ::[SubEmbed] -- ^ Fields of the embed + } deriving (Show, Read, Eq) + + instance FromJSON Embed where + parseJSON (Object o) = + Embed <$> o .:? "title" .!= "Untitled" + <*> o .: "type" + <*> o .:? "description" .!= "" + <*> o .:? "url" .!= "" + <*> o .:? "timestamp" .!= epochTime + <*> o .:? "color" .!= 0 + <*> sequence (HM.foldrWithKey to_embed [] o) + where + to_embed k (Object v) a + | k == pack "footer" = + (Footer <$> v .: "text" + <*> v .:? "icon_url" .!= "" + <*> v .:? "proxy_icon_url" .!= "") : a + | k == pack "image" = + (Image <$> v .: "url" + <*> v .: "proxy_url" + <*> v .: "height" + <*> v .: "width") : a + | k == pack "thumbnail" = + (Thumbnail <$> v .: "url" + <*> v .: "proxy_url" + <*> v .: "height" + <*> v .: "width") : a + | k == pack "video" = + (Video <$> v .: "url" + <*> v .: "height" + <*> v .: "width") : a + | k == pack "provider" = + (Provider <$> v .: "name" + <*> v .:? "url" .!= "") : a + | k == pack "author" = + (Author <$> v .: "name" + <*> v .:? "url" .!= "" + <*> v .:? "icon_url" .!= "" + <*> v .:? "proxy_icon_url" .!= "") : a + to_embed k (Array v) a + | k == pack "fields" = + [Field <$> i .: "name" + <*> i .: "value" + <*> i .: "inline" + | Object i <- toList v] ++ a + to_embed _ _ a = a + + parseJSON _ = mzero + + instance ToJSON Embed where + toJSON (Embed {..}) = object + [ "title" .= embedTitle + , "type" .= embedType + , "description" .= embedDesc + , "url" .= embedUrl + , "timestamp" .= embedTime + , "color" .= embedColor + ] |> makeSubEmbeds embedFields + where + (Object o) |> hm = Object $ HM.union o hm + _ |> _ = error "Type mismatch" + makeSubEmbeds = foldr embed HM.empty + 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 + + -- |Represents a part of an embed. + data SubEmbed + = Thumbnail + String + String + Integer + Integer + | Video + String + Integer + Integer + | Image + String + String + Integer + Integer + | Provider + String + String + | Author + String + String + String + String + | Footer + String + String + String + | Field + String + String + Bool + deriving (Show, Read, Eq) diff --git a/src/Network/Discord/Types/Events.hs b/src/Network/Discord/Types/Events.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Events.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings, GADTs #-} +-- | Data structures pertaining to gateway dispatch 'Event's +module Network.Discord.Types.Events where + import Control.Monad (mzero) + + import Data.Aeson + + import Network.Discord.Types.Channel + import Network.Discord.Types.Gateway + import Network.Discord.Types.Guild (Member, Guild) + import Network.Discord.Types.Prelude + + -- |Represents data sent on READY event. + data Init = Init Int User [Channel] [Guild] String deriving Show + + -- |Allows Init type to be generated using a JSON response by Discord. + instance FromJSON Init where + parseJSON (Object o) = Init <$> o .: "v" + <*> o .: "user" + <*> o .: "private_channels" + <*> o .: "guilds" + <*> o .: "session_id" + parseJSON _ = mzero + + -- |Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway. + data Event = + Ready Init + | Resumed Object + | ChannelCreate Channel + | ChannelUpdate Channel + | ChannelDelete Channel + | GuildCreate Guild + | GuildUpdate Guild + | GuildDelete Guild + | GuildBanAdd Member + | GuildBanRemove Member + | GuildEmojiUpdate Object + | GuildIntegrationsUpdate Object + | GuildMemberAdd Member + | GuildMemberRemove Member + | GuildMemberUpdate Member + | GuildMemberChunk Object + | GuildRoleCreate Object + | GuildRoleUpdate Object + | GuildRoleDelete Object + | MessageCreate Message + | MessageUpdate Message + | MessageDelete Object + | MessageDeleteBulk Object + | PresenceUpdate Object + | TypingStart Object + | UserSettingsUpdate Object + | UserUpdate Object + | VoiceStateUpdate Object + | VoiceServerUpdate Object + | UnknownEvent String Object + | Nil + deriving Show + + -- |Parses JSON stuff by Discord to an event type. + parseDispatch :: Payload -> Either String Event + parseDispatch (Dispatch ob _ ev) = case ev of + "READY" -> Ready <$> reparse o + "RESUMED" -> Resumed <$> reparse o + "CHANNEL_CREATE" -> ChannelCreate <$> reparse o + "CHANNEL_UPDATE" -> ChannelUpdate <$> reparse o + "CHANNEL_DELETE" -> ChannelDelete <$> reparse o + "GUILD_CREATE" -> GuildCreate <$> reparse o + "GUILD_UPDATE" -> GuildUpdate <$> reparse o + "GUILD_DELETE" -> GuildDelete <$> reparse o + "GUILD_BAN_ADD" -> GuildBanAdd <$> reparse o + "GUILD_BAN_REMOVE" -> GuildBanRemove <$> reparse o + "GUILD_EMOJI_UPDATE" -> GuildEmojiUpdate <$> reparse o + "GUILD_INTEGRATIONS_UPDATE" -> GuildIntegrationsUpdate <$> reparse o + "GUILD_MEMBER_ADD" -> GuildMemberAdd <$> reparse o + "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> reparse o + "GUILD_MEMBER_REMOVE" -> GuildMemberRemove <$> reparse o + "GUILD_MEMBER_CHUNK" -> GuildMemberChunk <$> reparse o + "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> reparse o + "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> reparse o + "GUILD_ROLE_DELETE" -> GuildRoleDelete <$> reparse o + "MESSAGE_CREATE" -> MessageCreate <$> reparse o + "MESSAGE_UPDATE" -> MessageUpdate <$> reparse o + "MESSAGE_DELETE" -> MessageDelete <$> reparse o + "MESSAGE_DELETE_BULK" -> MessageDeleteBulk <$> reparse o + "PRESENCE_UPDATE" -> PresenceUpdate <$> reparse o + "TYPING_START" -> TypingStart <$> reparse o + "USER_SETTINGS_UPDATE" -> UserSettingsUpdate <$> reparse o + "VOICE_STATE_UPDATE" -> VoiceStateUpdate <$> reparse o + "VOICE_SERVER_UPDATE" -> VoiceServerUpdate <$> reparse o + _ -> UnknownEvent ev <$> reparse o + where o = Object ob + parseDispatch _ = error "Tried to parse non-Dispatch payload" + diff --git a/src/Network/Discord/Types/Gateway.hs b/src/Network/Discord/Types/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Gateway.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Data structures needed for interfacing with the Websocket +-- Gateway +module Network.Discord.Types.Gateway where + import Control.Monad (mzero) + import System.Info + + import Data.Aeson + import Data.Aeson.Types + + import Network.Discord.Types.Prelude + + -- |Represents all sorts of things that we can send to Discord. + data Payload + = Dispatch + Object + Integer + String + | Heartbeat + Integer + | Identify + Auth + Bool + Integer + (Int, Int) + | StatusUpdate + (Maybe Integer) + (Maybe String) + | VoiceStatusUpdate + {-# UNPACK #-} !Snowflake + !(Maybe Snowflake) + Bool + Bool + | Resume + String + String + Integer + | Reconnect + | RequestGuildMembers + {-# UNPACK #-} !Snowflake + String + Integer + | InvalidSession + | Hello + Int + | HeartbeatAck + | ParseError String + deriving Show + + instance FromJSON Payload where + parseJSON = withObject "payload" $ \o -> do + op <- o .: "op" :: Parser Int + case op of + 0 -> Dispatch <$> o .: "d" <*> o .: "s" <*> o .: "t" + 1 -> Heartbeat <$> o .: "d" + 7 -> return Reconnect + 9 -> return InvalidSession + 10 -> (\od -> Hello <$> od .: "heartbeat_interval") =<< o .: "d" + 11 -> return HeartbeatAck + _ -> mzero + + instance ToJSON Payload where + toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= i ] + toJSON (Identify token compress large shard) = object [ + "op" .= (2 :: Int) + , "d" .= object [ + "token" .= authToken token + , "properties" .= object [ + "$os" .= os + , "$browser" .= ("discord.hs" :: String) + , "$device" .= ("discord.hs" :: String) + , "$referrer" .= ("" :: String) + , "$referring_domain" .= ("" :: String) + ] + , "compress" .= compress + , "large_threshold" .= large + , "shard" .= shard + ] + ] + toJSON (StatusUpdate idle game) = object [ + "op" .= (3 :: Int) + , "d" .= object [ + "idle_since" .= idle + , "game" .= object [ + "name" .= game + ] + ] + ] + toJSON (VoiceStatusUpdate guild channel mute deaf) = object [ + "op" .= (4 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "channel_id" .= channel + , "self_mute" .= mute + , "self_deaf" .= deaf + ] + ] + toJSON (Resume token session seqId) = object [ + "op" .= (6 :: Int) + , "d" .= object [ + "token" .= token + , "session_id" .= session + , "seq" .= seqId + ] + ] + toJSON (RequestGuildMembers guild query limit) = object [ + "op" .= (8 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "query" .= query + , "limit" .= limit + ] + ] + toJSON _ = object [] diff --git a/src/Network/Discord/Types/Guild.hs b/src/Network/Discord/Types/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Guild.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Types relating to Discord Guilds (servers) +module Network.Discord.Types.Guild where + import Data.Time.Clock + + import Data.Aeson + import Control.Applicative ((<|>)) + import Control.Monad (mzero) + + import Network.Discord.Types.Channel + import Network.Discord.Types.Prelude + + -- |Representation of a guild member. + data Member = GuildMember {-# UNPACK #-} !Snowflake User + | MemberShort User (Maybe String) ![Snowflake] + deriving Show + instance FromJSON Member where + parseJSON (Object o) = + GuildMember <$> o .: "guild_id" <*> o .: "user" + parseJSON _ = mzero + + -- | Guilds in Discord represent a collection of users and channels into an isolated + -- "Server" + data Guild + = Guild + { guildId :: {-# UNPACK #-} !Snowflake -- ^ Gulid id + , guildName :: String -- ^ Guild name (2 - 100 chars) + , guildIcon :: String -- ^ Icon hash + , guildSplash :: String -- ^ Splash hash + , guildOwner :: !Snowflake -- ^ Guild owner id + , guildRegion :: String -- ^ Guild voice region + , guildAfkId :: !Snowflake -- ^ Id of afk channel + , guildAfkTimeout :: !Integer -- ^ Afk timeout in seconds + , guildEmbedEnabled :: !Bool -- ^ Is this guild embeddable? + , guildEmbedChannel :: !Snowflake -- ^ Id of embedded channel + , guildVerification :: !Integer -- ^ Level of verification + , guildNotification :: !Integer -- ^ Level of default notifications + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + } + | Unavailable + { guildId :: {-# UNPACK #-} !Snowflake + } deriving Show + + instance FromJSON Guild where + parseJSON (Object o) = do + short <- o .:? "unavailable" .!= False + if short + then Unavailable <$> o .: "id" + else + Guild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" .!= "" + <*> o .:? "hash" .!= "" + <*> o .: "owner_id" + <*> o .: "region" + <*> o .:? "afk_channel_id" .!= 0 + <*> o .:? "afk_timeout" .!= 0 + <*> o .:? "embed_enabled" .!= False + <*> o .:? "embed_channel_id" .!= 0 + <*> o .: "verification_level" + <*> o .: "default_message_notifications" + <*> o .: "roles" + <*> o .: "emojis" + parseJSON _ = mzero + + -- | Represents an emoticon (emoji) + data Emoji = Emoji + { emojiId :: {-# UNPACK #-} !Snowflake -- ^ The emoji id + , emojiName :: String -- ^ The emoji name + , emojiRoles :: ![Snowflake] -- ^ Roles the emoji is active for + , emojiManaged :: !Bool -- ^ Whether this emoji is managed + } deriving (Show) + + instance FromJSON Emoji where + parseJSON (Object o) = + Emoji <$> o .: "id" + <*> o .: "name" + <*> o .: "roles" + <*> o .: "managed" + parseJSON _ = mzero + + -- | Roles represent a set of permissions attached to a group of users. Roles have unique + -- names, colors, and can be "pinned" to the side bar, causing their members to be listed separately. + -- Roles are unique per guild, and can have separate permission profiles for the global context + -- (guild) and channel context. + data Role = + Role { + roleID :: {-# UNPACK #-} !Snowflake -- ^ The role id + , roleName :: String -- ^ The role name + , roleColor :: Integer -- ^ Integer representation of color code + , roleHoist :: Bool -- ^ If the role is pinned in the user listing + , rolePos :: Integer -- ^ Position of this role + , rolePerms :: Integer -- ^ Permission bit set + , roleManaged :: Bool -- ^ Whether this role is managed by an integration + , roleMention :: Bool -- ^ Whether this role is mentionable + } deriving (Show, Eq) + + instance FromJSON Role where + parseJSON (Object o) = Role + <$> o .: "id" + <*> o .: "name" + <*> o .: "color" + <*> o .: "hoist" + <*> o .: "position" + <*> o .: "permissions" + <*> o .: "managed" + <*> o .: "mentionable" + parseJSON _ = mzero + + -- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added + data VoiceRegion = + VoiceRegion + { regionId :: {-# UNPACK #-} !Snowflake -- ^ Unique id of the region + , regionName :: String -- ^ Name of the region + , regionHostname :: String -- ^ Example hostname for the region + , regionPort :: Int -- ^ Example port for the region + , regionVip :: Bool -- ^ True if this is a VIP only server + , regionOptimal :: Bool -- ^ True for the closest server to a client + , regionDepreciated :: Bool -- ^ Whether this is a deprecated region + , regionCustom :: Bool -- ^ Whether this is a custom region + } deriving (Show) + + instance FromJSON VoiceRegion where + parseJSON (Object o) = VoiceRegion + <$> o .: "id" + <*> o .: "name" + <*> o .: "sample_hostname" + <*> o .: "sample_port" + <*> o .: "vip" + <*> o .: "optimal" + <*> o .: "deprecated" + <*> o .: "custom" + parseJSON _ = mzero + + -- | Represents a code to add a user to a guild + data Invite = + Invite { + inviteCode :: String -- ^ The invite code + , inviteGuild :: !Snowflake -- ^ The guild the code will invite to + , inviteChan :: !Snowflake -- ^ The channel the code will invite to + } + -- | Invite code with additional metadata + | InviteLong Invite InviteMeta + + instance FromJSON Invite where + parseJSON ob@(Object o) = + InviteLong <$> parseJSON ob <*> parseJSON ob + <|> Invite + <$> o .: "code" + <*> ((o .: "guild") >>= (.: "id")) + <*> ((o .: "channel") >>= (.: "id")) + parseJSON _ = mzero + + -- | Additional metadata about an invite. + data InviteMeta = + InviteMeta { + inviteCreator :: User -- ^ The user that created the invite + , inviteUses :: Integer -- ^ Number of times the invite has been used + , inviteMax :: Integer -- ^ Max number of times the invite can be used + , inviteAge :: Integer -- ^ The duration (in seconds) after which the invite expires + , inviteTemp :: Bool -- ^ Whether this invite only grants temporary membership + , inviteCreated :: UTCTime -- ^ When the invite was created + , inviteRevoked :: Bool -- ^ If the invite is revoked + } + + instance FromJSON InviteMeta where + parseJSON (Object o) = InviteMeta + <$> o .: "inviter" + <*> o .: "uses" + <*> o .: "max_uses" + <*> o .: "max_age" + <*> o .: "temporary" + <*> o .: "created_at" + <*> o .: "revoked" + parseJSON _ = mzero + + -- | Represents the behavior of a third party account link. + data Integration = + Integration + { integrationId :: {-# UNPACK #-} !Snowflake -- ^ Integration id + , integrationName :: String -- ^ Integration name + , integrationType :: String -- ^ Integration type (Twitch, Youtube, ect.) + , integrationEnabled :: Bool -- ^ Is the integration enabled + , integrationSyncing :: Bool -- ^ Is the integration syncing + , integrationRole :: Snowflake -- ^ Id the integration uses for "subscribers" + , integrationBehavior :: Integer -- ^ The behavior of expiring subscribers + , integrationGrace :: Integer -- ^ The grace period before expiring subscribers + , integrationOwner :: User -- ^ The user of the integration + , integrationAccount :: IntegrationAccount -- ^ The account the integration links to + , integrationSync :: UTCTime -- ^ When the integration was last synced + } deriving (Show) + + instance FromJSON Integration where + parseJSON (Object o) = Integration + <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "enabled" + <*> o .: "syncing" + <*> o .: "role_id" + <*> o .: "expire_behavior" + <*> o .: "expire_grace_period" + <*> o .: "user" + <*> o .: "account" + <*> o .: "synced_at" + parseJSON _ = mzero + + -- | Represents a third party account link. + data IntegrationAccount = + Account + { accountId :: String -- ^ The id of the account. + , accountName :: String -- ^ The name of the account. + } deriving (Show) + + instance FromJSON IntegrationAccount where + parseJSON (Object o) = Account + <$> o .: "id" + <*> o .: "name" + parseJSON _ = mzero + + -- | Represents an image to be used in third party sites to link to a discord channel + data GuildEmbed = + GuildEmbed + { embedEnabled :: !Bool -- ^ Whether the embed is enabled + , embedChannel :: {-# UNPACK #-} !Snowflake -- ^ The embed channel id + } + instance FromJSON GuildEmbed where + parseJSON (Object o) = GuildEmbed + <$> o .: "enabled" + <*> o .: "snowflake" + parseJSON _ = mzero + + instance ToJSON GuildEmbed where + toJSON (GuildEmbed enabled snowflake) = object + [ "enabled" .= enabled + , "snowflake" .= snowflake + ] diff --git a/src/Network/Discord/Types/Prelude.hs b/src/Network/Discord/Types/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Prelude.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} +-- | Provides base types and utility functions needed for modules in Network.Discord.Types +module Network.Discord.Types.Prelude where + import Data.Bits + import Data.Word + + import Data.Aeson.Types + import Data.Hashable + import Data.Text + import Data.Time.Clock + import Data.Time.Clock.POSIX + import Control.Monad (mzero) + + -- | Authorization token for the Discord API + data Auth = Bot String + | Client String + | Bearer String + + -- | Formats the token for use with the REST API + instance Show Auth where + show (Bot token) = "Bot " ++ token + show (Client token) = token + show (Bearer token) = "Bearer " ++ token + + -- | Get the raw token formatted for use with the websocket gateway + authToken :: Auth -> String + authToken (Bot token) = token + authToken (Client token) = token + authToken (Bearer token) = token + + -- | A unique integer identifier. Can be used to calculate the creation date of an entity. + newtype Snowflake = Snowflake Word64 + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits, Hashable) + + instance Show Snowflake where + show (Snowflake a) = show a + + instance ToJSON Snowflake where + toJSON (Snowflake snowflake) = String . pack $ show snowflake + + instance FromJSON Snowflake where + parseJSON (String snowflake) = Snowflake <$> (return . read $ unpack snowflake) + parseJSON _ = mzero + + -- |Gets a creation date from a snowflake. + creationDate :: Snowflake -> UTCTime + creationDate x = posixSecondsToUTCTime . realToFrac + $ 1420070400 + quot (shiftR x 22) 1000 + + -- | Default timestamp + epochTime :: UTCTime + epochTime = posixSecondsToUTCTime 0 + + -- | Return only the Right vaule from an either + justRight :: (Show a) => Either a b -> b + justRight (Right b) = b + justRight (Left a) = error $ show a + + -- | Convert ToJSON values to FromJSON values + reparse :: (ToJSON a, FromJSON b) => a -> Either String b + reparse val = parseEither parseJSON $ toJSON val