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
data User = User
{ userId :: !Snowflake
, userName :: String
, userDiscrim :: String
, userAvatar :: Maybe String
, userIsBot :: Bool
, userMfa :: Maybe Bool
, userVerified :: Maybe Bool
, userEmail :: Maybe String
}
| 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
data Channel
= Text
{ channelId :: Snowflake
, channelGuild :: Snowflake
, channelName :: String
, channelPosition :: Integer
, channelPermissions :: [Overwrite]
, channelTopic :: String
, channelLastMessage :: Snowflake
}
| Voice
{ channelId:: Snowflake
, channelGuild:: Snowflake
, channelName:: String
, channelPosition:: Integer
, channelPermissions:: [Overwrite]
, channelBitRate:: Integer
, channelUserLimit:: Integer
}
| DirectMessage
{ channelId :: Snowflake
, channelRecipients :: [User]
, 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
data Overwrite = Overwrite
{ overwriteId:: !Snowflake
, overWriteType:: String
, overwriteAllow:: Integer
, overwriteDeny:: Integer
} deriving (Show, Eq)
instance FromJSON Overwrite where
parseJSON (Object o) =
Overwrite <$> o .: "id"
<*> o .: "type"
<*> o .: "allow"
<*> o .: "deny"
parseJSON _ = mzero
data Message = Message
{ messageId :: !Snowflake
, messageChannel :: !Snowflake
, messageAuthor :: User
, messageContent :: Text
, messageTimestamp :: UTCTime
, messageEdited :: Maybe UTCTime
, messageTts :: Bool
, messageEveryone :: Bool
, messageMentions :: [User]
, messageMentionRoles :: [Snowflake]
, messageAttachments :: [Attachment]
, messageEmbeds :: [Embed]
, messageNonce :: Maybe Snowflake
, messagePinned :: Bool
} 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
data Attachment = Attachment
{ attachmentId :: !Snowflake
, attachmentFilename :: String
, attachmentSize :: Integer
, attachmentUrl :: String
, attachmentProxy :: String
, attachmentHeight :: Maybe Integer
, attachmentWidth :: Maybe Integer
} 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
data Embed = Embed
{ embedTitle :: String
, embedType :: String
, embedDesc :: String
, embedUrl :: String
, embedTime :: UTCTime
, embedColor :: Integer
, embedFields ::[SubEmbed]
} 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
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)