discord-haskell 1.3.0 → 1.4.0

raw patch · 16 files changed

+448/−268 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +21/−0
• changelog.md +8/−0
• discord-haskell.cabal +3/−1
• src/Discord/Internal/Rest/Channel.hs +18/−10
• src/Discord/Internal/Rest/Emoji.hs +1/−1
• src/Discord/Internal/Rest/Guild.hs +8/−8
• src/Discord/Internal/Rest/HTTP.hs +2/−1
• src/Discord/Internal/Rest/Prelude.hs +2/−2
• src/Discord/Internal/Rest/User.hs +2/−2
• src/Discord/Internal/Rest/Webhook.hs +23/−11
• src/Discord/Internal/Types.hs +4/−0
• src/Discord/Internal/Types/Channel.hs +2/−231
• src/Discord/Internal/Types/Embed.hs +266/−0
• src/Discord/Internal/Types/Events.hs +1/−0
• src/Discord/Internal/Types/Guild.hs +2/−1
• src/Discord/Internal/Types/User.hs +85/−0

@@ -82,6 +82,27 @@ See [examples/ping-pong.hs](https://github.com/aquarial/discord-haskell/blob/master/examples/ping-pong.hs)  for a `CreateReaction` request in use.  +### Embeds++Embeds are special messages with boarders and images. [Example embed created by discord-haskell](./examples/embed-photo.jpg)++The `Embed` record (and sub-records) store embed data received from Discord.++The `CreateEmbed` record stores data when we want to create an embed.++`CreateEmbed` has a `Default` instance, so you only need to specify the fields you use:++```haskell+_ <- restCall dis (R.CreateMessageEmbed <channel_id> "Pong!" $+        def { createEmbedTitle = "Pong Embed"+            , createEmbedImage = Just $ CreateEmbedImageUpload <bytestring>+            , createEmbedThumbnail = Just $ CreateEmbedImageUrl+                    "https://avatars2.githubusercontent.com/u/37496339"+            })+```++Uploading a file each time is slow, prefer uploading images to a hosting site like imgur.com, and then referencing them.+  ### Limitations  The following features are not implemented:

@@ -5,6 +5,14 @@ ## master  +## 1.4.0++Rename `SubEmbed` to `EmbedPart`++New and improved Embed API: Add `CreateEmbed` record and `createEmbed :: CreateEmbed -> Embed`++`CreateEmbedImageUpload` implementation inspired by [Flutterlice](https://github.com/aquarial/discord-haskell/pull/32)+ ## 1.3.0  [PixeLinc](https://github.com/aquarial/discord-haskell/pull/33) Add `DeleteSingleReaction` rest-request, Add GuildId to `ReactinInfo`, Add `MESSAGE_REACTION_REMOVE_EMOJI` gateway event

@@ -1,7 +1,7 @@ cabal-version:       2.0 name:                discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs-version:             1.3.0+version:             1.4.0 description:         Functions and data types to write discord bots.                      Official discord docs <https://discordapp.com/developers/docs/reference>.                      .@@ -63,6 +63,8 @@                      , Discord.Internal.Types.Events                      , Discord.Internal.Types.Gateway                      , Discord.Internal.Types.Guild+                     , Discord.Internal.Types.User+                     , Discord.Internal.Types.Embed   build-depends:                        base >=4 && <5                      , aeson >=1.3.1.1 && <1.5

@@ -22,8 +22,9 @@ import Data.Monoid (mempty, (<>)) import qualified Data.Text as T import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Network.HTTP.Client (RequestBody (RequestBodyBS))-import Network.HTTP.Client.MultipartFormData (partFileRequestBody)+import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS, PartM) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R @@ -49,7 +50,7 @@   -- | Sends a message to a channel.   CreateMessage           :: ChannelId -> T.Text -> ChannelRequest Message   -- | Sends a message with an Embed to a channel.-  CreateMessageEmbed      :: ChannelId -> T.Text -> Embed -> ChannelRequest Message+  CreateMessageEmbed      :: ChannelId -> T.Text -> CreateEmbed -> ChannelRequest Message   -- | Sends a message with a file to a channel.   CreateMessageUploadFile :: ChannelId -> T.Text -> B.ByteString -> ChannelRequest Message   -- | Add an emoji reaction to a message. ID must be present for custom emoji@@ -65,7 +66,7 @@   -- | Delete all reactions on a message   DeleteAllReactions      :: (ChannelId, MessageId) -> ChannelRequest ()   -- | Edits a message content.-  EditMessage             :: (ChannelId, MessageId) -> T.Text -> Maybe Embed+  EditMessage             :: (ChannelId, MessageId) -> T.Text -> Maybe CreateEmbed                                                     -> ChannelRequest Message   -- | Deletes a message.   DeleteMessage           :: (ChannelId, MessageId) -> ChannelRequest ()@@ -216,8 +217,15 @@     (_, Just a) -> "custom:" <> a     (_, Nothing) -> noAngles -maybeEmbed :: Maybe Embed -> [(T.Text, Value)]-maybeEmbed = maybe [] $ \embed -> ["embed" .= embed]+maybeEmbed :: Maybe CreateEmbed -> [PartM IO]+maybeEmbed = --maybe [] $ \embed -> ["embed" .= createEmbed embed]+      let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content)+          uploads CreateEmbed{..} = [(n,c) | (n, Just (CreateEmbedImageUpload c)) <-+                                          [ ("author.png", createEmbedAuthorIcon)+                                          , ("thumbnail.png", createEmbedThumbnail)+                                          , ("image.png", createEmbedImage)+                                          , ("footer.png", createEmbedFooterIcon) ]]+      in maybe [] (map mkPart . uploads)  -- | The base url (Req) for API requests baseUrl :: R.Url 'R.Https@@ -233,7 +241,7 @@       Get (channels // chan) mempty    (ModifyChannel chan patch) ->-      Patch (channels // chan) (R.ReqBodyJson patch) mempty+      Patch (channels // chan) (pure (R.ReqBodyJson patch)) mempty    (DeleteChannel chan) ->       Delete (channels // chan) mempty@@ -252,8 +260,8 @@       in Post (channels // chan /: "messages") body mempty    (CreateMessageEmbed chan msg embed) ->-      let content = ["content" .= msg] <> maybeEmbed (Just embed)-          body = pure $ R.ReqBodyJson $ object content+      let partJson = partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["content" .= msg, "embed" .= createEmbed embed]+          body = R.reqBodyMultipart (partJson : maybeEmbed (Just embed))       in Post (channels // chan /: "messages") body mempty    (CreateMessageUploadFile chan fileName file) ->@@ -288,8 +296,8 @@       Delete (channels // chan /: "messages" // msgid /: "reactions" ) mempty    (EditMessage (chan, msg) new embed) ->-      let content = ["content" .= new] <> maybeEmbed embed-          body = R.ReqBodyJson $ object content+      let partJson = partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["content" .= new]+          body = R.reqBodyMultipart (partJson : maybeEmbed embed)       in Patch (channels // chan /: "messages" // msg) body mempty    (DeleteMessage (chan, msg)) ->

@@ -105,6 +105,6 @@                                                      ])))                         mempty   (ModifyGuildEmoji g e o) -> Patch (guilds // g /: "emojis" // e)-                                    (R.ReqBodyJson o)+                                    (pure (R.ReqBodyJson o))                                     mempty   (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty

@@ -357,7 +357,7 @@       Get (guilds // guild) mempty    (ModifyGuild guild patch) ->-      Patch (guilds // guild) (R.ReqBodyJson patch) mempty+      Patch (guilds // guild) (pure (R.ReqBodyJson patch)) mempty    (DeleteGuild guild) ->       Delete (guilds // guild) mempty@@ -372,7 +372,7 @@   (ModifyGuildChannelPositions guild newlocs) ->       let patch = map (\(a, b) -> object [("id", toJSON a)                                          ,("position", toJSON b)]) newlocs-      in Patch (guilds // guild /: "channels") (R.ReqBodyJson patch) mempty+      in Patch (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty    (GetGuildMember guild member) ->       Get (guilds // guild /: "members" // member) mempty@@ -384,11 +384,11 @@       Put (guilds // guild /: "members" // user) (R.ReqBodyJson patch) mempty    (ModifyGuildMember guild member patch) ->-      Patch (guilds // guild /: "members" // member) (R.ReqBodyJson patch) mempty+      Patch (guilds // guild /: "members" // member) (pure (R.ReqBodyJson patch)) mempty    (ModifyCurrentUserNick guild name) ->       let patch = object ["nick" .= name]-      in Patch (guilds // guild /: "members/@me/nick") (R.ReqBodyJson patch) mempty+      in Patch (guilds // guild /: "members/@me/nick") (pure (R.ReqBodyJson patch)) mempty    (AddGuildMemberRole guild user role) ->       let body = R.ReqBodyJson (object [])@@ -418,10 +418,10 @@    (ModifyGuildRolePositions guild patch) ->       let body = map (\(role, pos) -> object ["id".=role, "position".=pos]) patch-      in Patch (guilds // guild /: "roles") (R.ReqBodyJson body) mempty+      in Patch (guilds // guild /: "roles") (pure (R.ReqBodyJson body)) mempty    (ModifyGuildRole guild role patch) ->-      Patch (guilds // guild /: "roles" // role) (R.ReqBodyJson patch) mempty+      Patch (guilds // guild /: "roles" // role) (pure (R.ReqBodyJson patch)) mempty    (DeleteGuildRole guild role) ->       Delete (guilds // guild /: "roles" // role) mempty@@ -446,7 +446,7 @@       in Post (guilds // guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty    (ModifyGuildIntegration guild iid patch) ->-      let body = R.ReqBodyJson patch+      let body = pure (R.ReqBodyJson patch)       in Patch (guilds // guild /: "integrations" // iid) body mempty    (DeleteGuildIntegration guild integ) ->@@ -459,7 +459,7 @@       Get (guilds // guild /: "integrations") mempty    (ModifyGuildEmbed guild patch) ->-      Patch (guilds // guild /: "embed") (R.ReqBodyJson patch) mempty+      Patch (guilds // guild /: "embed") (pure (R.ReqBodyJson patch)) mempty    (GetGuildVanityURL guild) ->       Get (guilds // guild /: "vanity-url") mempty

@@ -128,7 +128,8 @@   action = case request of     (Delete url      opts) -> R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts)     (Get    url      opts) -> R.req R.GET    url R.NoReqBody R.lbsResponse (authopt <> opts)-    (Patch  url body opts) -> R.req R.PATCH  url body        R.lbsResponse (authopt <> opts)     (Put    url body opts) -> R.req R.PUT    url body        R.lbsResponse (authopt <> opts)+    (Patch  url body opts) -> do b <- body+                                 R.req R.PATCH  url b        R.lbsResponse (authopt <> opts)     (Post   url body opts) -> do b <- body                                  R.req R.POST   url b        R.lbsResponse (authopt <> opts)

@@ -25,7 +25,7 @@   where   -- | https://discordapp.com/developers/docs/reference#user-agent   -- Second place where the library version is noted-  agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.3.0)"+  agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.4.0)"  -- Append to an URL infixl 5 //@@ -37,8 +37,8 @@ data JsonRequest where   Delete ::                 R.Url 'R.Https ->      R.Option 'R.Https -> JsonRequest   Get    ::                 R.Url 'R.Https ->      R.Option 'R.Https -> JsonRequest-  Patch  :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest   Put    :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest+  Patch  :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest   Post   :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest  class Request a where

@@ -90,8 +90,8 @@   (GetUser user) -> Get (users // user ) mempty    (ModifyCurrentUser name (CurrentUserAvatar im)) ->-      Patch (users /: "@me")  (R.ReqBodyJson (object [ "username" .= name-                                                     , "avatar" .= im ])) mempty+      Patch (users /: "@me")  (pure (R.ReqBodyJson (object [ "username" .= name+                                                           , "avatar" .= im ]))) mempty    (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty 

@@ -16,11 +16,12 @@ import Data.Aeson import Data.Monoid (mempty, (<>)) import qualified Data.Text as T-import Network.HTTP.Req ((/:))-import qualified Network.HTTP.Req as R+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Network.HTTP.Client (RequestBody (RequestBodyLBS))-import Network.HTTP.Client.MultipartFormData (partFileRequestBody)+import           Network.HTTP.Req ((/:))+import qualified Network.HTTP.Req as R+import Network.HTTP.Client (RequestBody (RequestBodyBS))+import Network.HTTP.Client.MultipartFormData (partBS, partFileRequestBody)  import Discord.Internal.Rest.Prelude import Discord.Internal.Types@@ -74,15 +75,15 @@   deriving (Show, Eq, Ord)  data WebhookContent = WebhookContentText T.Text-                    | WebhookContentFile T.Text BL.ByteString-                    | WebhookContentEmbeds [Embed]+                    | WebhookContentFile T.Text B.ByteString+                    | WebhookContentEmbeds [CreateEmbed]   deriving (Show, Eq, Ord)  webhookContentJson :: WebhookContent -> [(T.Text, Value)] webhookContentJson c = case c of                       WebhookContentText t -> [("content", toJSON t)]                       WebhookContentFile _ _  -> []-                      WebhookContentEmbeds e -> [("embeds", toJSON e)]+                      WebhookContentEmbeds e -> [("embeds", toJSON (createEmbed <$> e))]  instance ToJSON ExecuteWebhookWithTokenOpts where   toJSON ExecuteWebhookWithTokenOpts{..} = object $ [(name, val) | (name, Just val) <-@@ -126,10 +127,10 @@     Get (baseUrl /: "webhooks" // w /: t)  mempty    (ModifyWebhook w patch) ->-    Patch (baseUrl /: "webhooks" // w) (R.ReqBodyJson patch)  mempty+    Patch (baseUrl /: "webhooks" // w) (pure (R.ReqBodyJson patch))  mempty    (ModifyWebhookWithToken w t p) ->-    Patch (baseUrl /: "webhooks" // w /: t) (R.ReqBodyJson p)  mempty+    Patch (baseUrl /: "webhooks" // w /: t) (pure (R.ReqBodyJson p))  mempty    (DeleteWebhook w) ->     Delete (baseUrl /: "webhooks" // w)  mempty@@ -140,9 +141,20 @@   (ExecuteWebhookWithToken w tok o) ->     case executeWebhookWithTokenOptsContent o of       WebhookContentFile name text  ->-        let part = partFileRequestBody "file" (T.unpack name) (RequestBodyLBS text)+        let part = partFileRequestBody "file" (T.unpack name) (RequestBodyBS text)             body = R.reqBodyMultipart [part]         in Post (baseUrl /: "webhooks" // w /: tok) body mempty-      _ ->+      WebhookContentText _ ->         let body = pure (R.ReqBodyJson o)+        in Post (baseUrl /: "webhooks" // w /: tok) body mempty+      WebhookContentEmbeds embeds ->+        let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content)+            uploads CreateEmbed{..} = [(n,c) | (n, Just (CreateEmbedImageUpload c)) <-+                                          [ ("author.png", createEmbedAuthorIcon)+                                          , ("thumbnail.png", createEmbedThumbnail)+                                          , ("image.png", createEmbedImage)+                                          , ("footer.png", createEmbedFooterIcon) ]]+            parts =  map mkPart (concatMap uploads embeds)+            partsJson = [partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["embed" .= createEmbed e] | e <- embeds]+            body = R.reqBodyMultipart (partsJson ++ parts)         in Post (baseUrl /: "webhooks" // w /: tok) body mempty

@@ -6,6 +6,8 @@   , module Discord.Internal.Types.Events   , module Discord.Internal.Types.Gateway   , module Discord.Internal.Types.Guild+  , module Discord.Internal.Types.User+  , module Discord.Internal.Types.Embed   , module Data.Aeson   , module Data.Time.Clock   ) where@@ -14,6 +16,8 @@ import Discord.Internal.Types.Events import Discord.Internal.Types.Gateway import Discord.Internal.Types.Guild+import Discord.Internal.Types.User+import Discord.Internal.Types.Embed import Discord.Internal.Types.Prelude  import Data.Aeson (Object)

@@ -7,91 +7,14 @@ 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---- | Represents information about a user.-data User = User-  { userId       :: UserId       -- ^ The user's id.-  , userName     :: T.Text       -- ^ The user's username (not unique)-  , userDiscrim  :: T.Text       -- ^ The user's 4-digit discord-tag.-  , userAvatar   :: Maybe T.Text -- ^ The user's avatar hash.-  , userIsBot    :: Bool         -- ^ User is an OAuth2 application.-  , userIsWebhook:: Bool         -- ^ User is a webhook-  , userMfa      :: Maybe Bool   -- ^ User has two factor authentication enabled on the account.-  , userVerified :: Maybe Bool   -- ^ Whether the email has been verified.-  , userEmail    :: Maybe T.Text -- ^ The user's email.-  } 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 -- webhook-         <*> 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")-+import Discord.Internal.Types.User (User(..))+import Discord.Internal.Types.Embed  -- | Guild channels represent an isolated set of users and messages in a Guild (Server) data Channel@@ -301,159 +224,7 @@                <*> o .:? "height"                <*> o .:? "width" --- | An embed attached to a message.-data Embed = Embed-  { embedTitle       :: Maybe T.Text     -- ^ Title of the embed-  , embedType        :: Maybe T.Text     -- ^ Type of embed (Always "rich" for webhooks)-  , embedDescription :: Maybe T.Text     -- ^ Description of embed-  , embedUrl         :: Maybe T.Text     -- ^ URL of embed-  , embedTimestamp   :: Maybe UTCTime    -- ^ The time of the embed content-  , embedColor       :: Maybe Integer    -- ^ The embed color-  , embedFields      :: [SubEmbed]       -- ^ Fields of the embed-  } 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---- | Represents a part of an embed.-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)

@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Data structures pertaining to Discord Embed+module Discord.Internal.Types.Embed where++import Data.Aeson+import Data.Time.Clock+import Data.Default (Default, def)+import qualified Data.Text as T+import qualified Data.ByteString as B++createEmbed :: CreateEmbed -> Embed+createEmbed CreateEmbed{..} =+  let+    emptyMaybe :: T.Text -> Maybe T.Text+    emptyMaybe t = if T.null t then Nothing else Just t++    embedImageToUrl :: T.Text -> CreateEmbedImage -> T.Text+    embedImageToUrl place cei = case cei of+                            CreateEmbedImageUrl t -> t+                            CreateEmbedImageUpload _ -> "attachment://" <> place <> ".png"++    embedAuthor = EmbedAuthor (emptyMaybe createEmbedAuthorName)+                              (emptyMaybe createEmbedAuthorUrl)+                              (embedImageToUrl "author" <$> createEmbedAuthorIcon)+                              Nothing+    embedImage = EmbedImage   (embedImageToUrl "image" <$> createEmbedImage)+                              Nothing Nothing Nothing+    embedThumbnail = EmbedThumbnail (embedImageToUrl "thumbnail" <$> createEmbedThumbnail)+                              Nothing Nothing Nothing+    embedFooter = EmbedFooter createEmbedFooterText+                              (embedImageToUrl "footer" <$> createEmbedFooterIcon)+                              Nothing++  in Embed { embedAuthor      = Just embedAuthor+           , embedTitle       = emptyMaybe createEmbedTitle+           , embedUrl         = emptyMaybe createEmbedUrl+           , embedThumbnail   = Just embedThumbnail+           , embedDescription = emptyMaybe createEmbedDescription+           , embedFields      = createEmbedFields+           , embedImage       = Just embedImage+           , embedFooter      = Just embedFooter+           , embedColor       = Nothing+           , embedTimestamp   = Nothing++           -- can't set these+           , embedType        = Nothing+           , embedVideo       = Nothing+           , embedProvider    = Nothing+           }++data CreateEmbed = CreateEmbed+  { createEmbedAuthorName  :: T.Text+  , createEmbedAuthorUrl   :: T.Text+  , createEmbedAuthorIcon  :: Maybe CreateEmbedImage+  , createEmbedTitle       :: T.Text+  , createEmbedUrl         :: T.Text+  , createEmbedThumbnail   :: Maybe CreateEmbedImage+  , createEmbedDescription :: T.Text+  , createEmbedFields      :: [EmbedField]+  , createEmbedImage       :: Maybe CreateEmbedImage+  , createEmbedFooterText  :: T.Text+  , createEmbedFooterIcon  :: Maybe CreateEmbedImage+--, createEmbedColor       :: Maybe T.Text+--, createEmbedTimestamp   :: Maybe UTCTime+  } deriving (Show, Eq, Ord)++data CreateEmbedImage = CreateEmbedImageUrl T.Text+                      | CreateEmbedImageUpload B.ByteString+  deriving (Show, Eq, Ord)++instance Default CreateEmbed where+ def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing -- Nothing Nothing++-- | An embed attached to a message.+data Embed = Embed+  { embedAuthor      :: Maybe EmbedAuthor+  , embedTitle       :: Maybe T.Text     -- ^ Title of the embed+  , embedUrl         :: Maybe T.Text     -- ^ URL of embed+  , embedThumbnail   :: Maybe EmbedThumbnail -- ^ Thumbnail in top-right+  , embedDescription :: Maybe T.Text     -- ^ Description of embed+  , embedFields      :: [EmbedField]     -- ^ Fields of the embed+  , embedImage       :: Maybe EmbedImage+  , embedFooter      :: Maybe EmbedFooter++  , embedColor       :: Maybe Integer    -- ^ The embed color+  , embedTimestamp   :: Maybe UTCTime    -- ^ The time of the embed content+  , embedType        :: Maybe T.Text     -- ^ Type of embed (Always "rich" for users)+  , embedVideo       :: Maybe EmbedVideo -- ^ Only present for "video" types+  , embedProvider    :: Maybe EmbedProvider -- ^ Only present for "video" types+  } deriving (Show, Eq, Ord)++-- TODO+instance ToJSON Embed where+  toJSON Embed{..} = object+   [ "author"      .= embedAuthor+   , "title"       .= embedTitle+   , "url"         .= embedUrl+   , "description" .= embedDescription+   , "thumbnail"   .= embedThumbnail+   , "fields"      .= embedFields+   , "image"       .= embedImage+   , "footer"      .= embedFooter+   , "color"       .= embedColor+   , "timestamp"   .= embedTimestamp+   , "type"        .= embedType+   , "video"       .= embedVideo+   , "provider"    .= embedProvider+    ]++instance FromJSON Embed where+  parseJSON = withObject "embed" $ \o ->+    Embed <$> o .:? "author"+          <*> o .:? "title"+          <*> o .:? "url"+          <*> o .:? "thumbnail"+          <*> o .:? "description"+          <*> o .:? "fields" .!= []+          <*> o .:? "image"+          <*> o .:? "footer"+          <*> o .:? "color"+          <*> o .:? "timestamp"+          <*> o .:? "type"+          <*> o .:? "video"+          <*> o .:? "provider"+++data EmbedThumbnail = EmbedThumbnail+  { embedThumbnailUrl :: Maybe T.Text+  , embedThumbnailProxyUrl :: Maybe T.Text+  , embedThumbnailHeight :: Maybe Integer+  , embedThumbnailWidth :: Maybe Integer+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedThumbnail where+  toJSON (EmbedThumbnail a b c d) = object+    [ "url" .= a+    , "proxy_url" .= b+    , "height" .= c+    , "width" .= d+    ]++instance FromJSON EmbedThumbnail where+  parseJSON = withObject "thumbnail" $ \o ->+    EmbedThumbnail <$> o .:? "url"+                   <*> o .:? "proxy_url"+                   <*> o .:? "height"+                   <*> o .:? "width"++data EmbedVideo = EmbedVideo+  { embedVideoUrl :: Maybe T.Text+  , embedVideoHeight :: Maybe Integer+  , embedVideoWidth :: Maybe Integer+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedVideo where+  toJSON (EmbedVideo a b c) = object+    [ "url" .= a+    , "height" .= b+    , "width" .= c+    ]++instance FromJSON EmbedVideo where+  parseJSON = withObject "video" $ \o ->+    EmbedVideo <$> o .:? "url"+               <*> o .:? "height"+               <*> o .:? "width"++data EmbedImage = EmbedImage+  { embedImageUrl :: Maybe T.Text+  , embedImageProxyUrl :: Maybe T.Text+  , embedImageHeight :: Maybe Integer+  , embedImageWidth :: Maybe Integer+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedImage where+  toJSON (EmbedImage a b c d) = object+    [ "url" .= a+    , "proxy_url" .= b+    , "height" .= c+    , "width" .= d+    ]++instance FromJSON EmbedImage where+  parseJSON = withObject "image" $ \o ->+    EmbedImage <$> o .:? "url"+               <*> o .:? "proxy_url"+               <*> o .:? "height"+               <*> o .:? "width"++data EmbedProvider = EmbedProvider+  { embedProviderName :: Maybe T.Text+  , embedProviderUrl :: Maybe T.Text+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedProvider where+  toJSON (EmbedProvider a b) = object+    [ "name" .= a+    , "url" .= b+    ]++instance FromJSON EmbedProvider where+  parseJSON = withObject "provider" $ \o ->+    EmbedProvider <$> o .:? "name"+                  <*> o .:? "url"++data EmbedAuthor = EmbedAuthor+  { embedAuthorName :: Maybe T.Text+  , embedAuthorUrl :: Maybe T.Text+  , embedAuthorIconUrl :: Maybe T.Text+  , embedAuthorProxyIconUrl :: Maybe T.Text+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedAuthor where+  toJSON (EmbedAuthor a b c d) = object+    [ "name" .= a+    , "url" .= b+    , "icon_url" .= c+    , "proxy_icon_url" .= d+    ]++instance FromJSON EmbedAuthor where+  parseJSON = withObject "author" $ \o ->+    EmbedAuthor <$> o .:? "name"+                <*> o .:? "url"+                <*> o .:? "icon_url"+                <*> o .:? "proxy_icon_url"++data EmbedFooter = EmbedFooter+  { embedFooterText :: T.Text+  , embedFooterIconUrl :: Maybe T.Text+  , embedFooterProxyIconUrl :: Maybe T.Text+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedFooter where+  toJSON (EmbedFooter a b c) = object+    [ "text" .= a+    , "icon_url" .= b+    , "proxy_icon_url" .= c+    ]++instance FromJSON EmbedFooter where+  parseJSON = withObject "footer" $ \o ->+    EmbedFooter <$> o .:  "text"+                <*> o .:? "icon_url"+                <*> o .:? "proxy_icon_url"++data EmbedField = EmbedField+  { embedFieldName :: T.Text+  , embedFieldValue :: T.Text+  , embedFieldInline :: Maybe Bool+  } deriving (Show, Eq, Ord)++instance ToJSON EmbedField where+  toJSON (EmbedField a b c) = object+    [ "name" .= a+    , "value" .= b+    , "inline" .= c+    ]++instance FromJSON EmbedField where+  parseJSON = withObject "field" $ \o ->+    EmbedField <$> o .:  "name"+               <*> o .:  "value"+               <*> o .:? "inline"

@@ -16,6 +16,7 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.Channel import Discord.Internal.Types.Guild+import Discord.Internal.Types.User (User)   -- | Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway.

@@ -8,8 +8,9 @@ import Data.Aeson import qualified Data.Text as T -import Discord.Internal.Types.Channel import Discord.Internal.Types.Prelude+import Discord.Internal.Types.Channel (Channel)+import Discord.Internal.Types.User (User)  -- | Representation of a guild member. data GuildMember = GuildMember

@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Data structures pertaining to Discord User+module Discord.Internal.Types.User where++import Data.Aeson+import Data.Text (Text)+import qualified Data.Text as T+import Discord.Internal.Types.Prelude++-- | Represents information about a user.+data User = User+  { userId       :: UserId       -- ^ The user's id.+  , userName     :: T.Text       -- ^ The user's username (not unique)+  , userDiscrim  :: T.Text       -- ^ The user's 4-digit discord-tag.+  , userAvatar   :: Maybe T.Text -- ^ The user's avatar hash.+  , userIsBot    :: Bool         -- ^ User is an OAuth2 application.+  , userIsWebhook:: Bool         -- ^ User is a webhook+  , userMfa      :: Maybe Bool   -- ^ User has two factor authentication enabled on the account.+  , userVerified :: Maybe Bool   -- ^ Whether the email has been verified.+  , userEmail    :: Maybe T.Text -- ^ The user's email.+  } 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 -- webhook+         <*> 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")