discord-rest (empty) → 0.2.2
raw patch · 8 files changed
+689/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, comonad, data-default, discord-types, hashable, hslogger, http-client, mtl, req, stm, text, time, url
Files
- LICENSE +20/−0
- discord-rest.cabal +48/−0
- src/Network/Discord/Rest.hs +34/−0
- src/Network/Discord/Rest/Channel.hs +140/−0
- src/Network/Discord/Rest/Guild.hs +227/−0
- src/Network/Discord/Rest/HTTP.hs +84/−0
- src/Network/Discord/Rest/Prelude.hs +62/−0
- src/Network/Discord/Rest/User.hs +74/−0
+ LICENSE view
@@ -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.
+ discord-rest.cabal view
@@ -0,0 +1,48 @@+name: discord-rest+version: 0.2.2+synopsis: An API wrapper for Discord in Haskell+description: Provides an api wrapper and framework for writing+ bots against the Discord <https://discordapp.com/> API.+ If for some reason hackage/stackage is failing to build+ documentation, a backup set is hosted at <https://jano017.github.io/Discord.hs/>+homepage: https://github.com/jano017/Discord.hs+license: MIT+license-file: LICENSE+author: Joshua Koike+maintainer: jkoike2013@gmail.com+-- copyright:+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Network.Discord.Rest+ , Network.Discord.Rest.Channel+ , Network.Discord.Rest.Guild+ , Network.Discord.Rest.User+ other-modules: Network.Discord.Rest.Prelude+ , Network.Discord.Rest.HTTP+ -- other-extensions:+ build-depends: base==4.*+ , discord-types+ , aeson>=1.0 && <1.2+ , bytestring==0.10.*+ , comonad==5.*+ , data-default==0.7.*+ , hashable==1.2.*+ , hslogger==1.2.*+ , http-client==0.5.*+ , mtl==2.2.*+ , req==0.2.*+ , stm==2.4.*+ , text==1.2.*+ , time>=1.6 && <1.9+ , url==2.1.*+ ghc-options: -Wall+ hs-source-dirs: src+ default-language: Haskell2010++source-repository head+ type : git+ location: https://github.com/jano017/Discord.hs
+ src/Network/Discord/Rest.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+{-# OPTIONS_HADDOCK prune, not-home #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Provides framework to interact with REST api gateways. Implementations specific to the+-- Discord API are provided in Network.Discord.Rest.Channel, Network.Discord.Rest.Guild,+-- and Network.Discord.Rest.User.+module Network.Discord.Rest+ ( module Network.Discord.Rest+ , module Network.Discord.Rest.Prelude+ , module Network.Discord.Rest.Channel+ , module Network.Discord.Rest.Guild+ , module Network.Discord.Rest.User+ ) where+ import Data.Maybe (fromJust)++ import qualified Network.HTTP.Req as R+ import Data.Aeson.Types+ import Network.URL++ import Network.Discord.Rest.Channel+ import Network.Discord.Rest.Guild+ import Network.Discord.Rest.Prelude+ import Network.Discord.Rest.User+ import Network.Discord.Rest.HTTP (baseUrl)++ -- | Obtains a new gateway to connect to.+ getGateway :: DiscordRest m => m URL+ getGateway = do+ r <- R.req R.GET (baseUrl R./: "gateway") R.NoReqBody R.jsonResponse mempty+ return . fromJust $ importURL =<< parseMaybe getURL (R.responseBody r)+ where+ getURL :: Value -> Parser String+ getURL = withObject "url" (.: "url")
+ src/Network/Discord/Rest/Channel.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- | Provides actions for Channel API interactions+module Network.Discord.Rest.Channel+ (+ ChannelRequest(..)+ ) where++ import Data.Aeson+ import Data.ByteString.Lazy+ import Data.Hashable+ import Data.Monoid (mempty, (<>))+ import Data.Text as T+ import Network.HTTP.Client (RequestBody (..))+ import Network.HTTP.Client.MultipartFormData (partFileRequestBody)+ import Network.HTTP.Req (reqBodyMultipart)++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types+ import Network.Discord.Rest.HTTP++ -- | Data constructor for Channel requests. See <https://discordapp.com/developers/docs/resources/Channel Channel API>+ data ChannelRequest a where+ -- | Gets a channel by its id.+ GetChannel :: Snowflake -> ChannelRequest Channel+ -- | Edits channels options.+ ModifyChannel :: ToJSON a => Snowflake -> a -> ChannelRequest Channel+ -- | Deletes a channel if its id doesn't equal to the id of guild.+ DeleteChannel :: Snowflake -> ChannelRequest Channel+ -- | Gets a messages from a channel with limit of 100 per request.+ GetChannelMessages :: Snowflake -> Range -> ChannelRequest [Message]+ -- | Gets a message in a channel by its id.+ GetChannelMessage :: Snowflake -> Snowflake -> ChannelRequest Message+ -- | Sends a message to a channel.+ CreateMessage :: Snowflake -> Text -> Maybe Embed -> ChannelRequest Message+ -- | Sends a message with a file to a channel.+ UploadFile :: Snowflake -> FilePath -> ByteString -> ChannelRequest Message+ -- | Edits a message content.+ EditMessage :: Message -> Text -> Maybe Embed -> ChannelRequest Message+ -- | Deletes a message.+ DeleteMessage :: Message -> ChannelRequest ()+ -- | Deletes a group of messages.+ BulkDeleteMessage :: Snowflake -> [Message] -> ChannelRequest ()+ -- | Edits a permission overrides for a channel.+ EditChannelPermissions :: ToJSON a => Snowflake -> Snowflake -> a -> ChannelRequest ()+ -- | Gets all instant invites to a channel.+ GetChannelInvites :: Snowflake -> ChannelRequest Object+ -- | Creates an instant invite to a channel.+ CreateChannelInvite :: ToJSON a => Snowflake -> a -> ChannelRequest Object+ -- | Deletes a permission override from a channel.+ DeleteChannelPermission :: Snowflake -> Snowflake -> ChannelRequest ()+ -- | Sends a typing indicator a channel which lasts 10 seconds.+ TriggerTypingIndicator :: Snowflake -> ChannelRequest ()+ -- | Gets all pinned messages of a channel.+ GetPinnedMessages :: Snowflake -> ChannelRequest [Message]+ -- | Pins a message.+ AddPinnedMessage :: Snowflake -> Snowflake -> ChannelRequest ()+ -- | Unpins a message.+ DeletePinnedMessage :: Snowflake -> Snowflake -> ChannelRequest ()++ instance Hashable (ChannelRequest a) where+ hashWithSalt s (GetChannel chan) = hashWithSalt s ("get_chan"::Text, chan)+ hashWithSalt s (ModifyChannel chan _) = hashWithSalt s ("mod_chan"::Text, chan)+ hashWithSalt s (DeleteChannel chan) = hashWithSalt s ("mod_chan"::Text, chan)+ hashWithSalt s (GetChannelMessages chan _) = hashWithSalt s ("msg"::Text, chan)+ hashWithSalt s (GetChannelMessage chan _) = hashWithSalt s ("get_msg"::Text, chan)+ hashWithSalt s (CreateMessage chan _ _) = hashWithSalt s ("msg"::Text, chan)+ hashWithSalt s (UploadFile chan _ _) = hashWithSalt s ("msg"::Text, chan)+ hashWithSalt s (EditMessage (Message _ chan _ _ _ _ _ _ _ _ _ _ _ _) _ _) =+ hashWithSalt s ("get_msg"::Text, chan)+ hashWithSalt s (DeleteMessage (Message _ chan _ _ _ _ _ _ _ _ _ _ _ _)) =+ hashWithSalt s ("get_msg"::Text, chan)+ hashWithSalt s (BulkDeleteMessage chan _) = hashWithSalt s ("del_msgs"::Text, chan)+ hashWithSalt s (EditChannelPermissions chan _ _) = hashWithSalt s ("perms"::Text, chan)+ hashWithSalt s (GetChannelInvites chan) = hashWithSalt s ("invites"::Text, chan)+ hashWithSalt s (CreateChannelInvite chan _) = hashWithSalt s ("invites"::Text, chan)+ hashWithSalt s (DeleteChannelPermission chan _) = hashWithSalt s ("perms"::Text, chan)+ hashWithSalt s (TriggerTypingIndicator chan) = hashWithSalt s ("tti"::Text, chan)+ hashWithSalt s (GetPinnedMessages chan) = hashWithSalt s ("pins"::Text, chan)+ hashWithSalt s (AddPinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)+ hashWithSalt s (DeletePinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)++ instance (FromJSON a) => DoFetch ChannelRequest a where+ doFetch req = go req+ where+ maybeEmbed :: Maybe Embed -> [(Text, Value)]+ maybeEmbed = maybe [] $ \embed -> ["embed" .= embed]++ url = baseUrl /: "channels"++ go :: DiscordRest m => ChannelRequest a -> m a+ go r@(GetChannel chan) = makeRequest r+ $ Get (url // chan) mempty+ go r@(ModifyChannel chan patch) = makeRequest r+ $ Patch (url // chan)+ (ReqBodyJson patch) mempty+ go r@(DeleteChannel chan) = makeRequest r+ $ Delete (url // chan) mempty+ go r@(GetChannelMessages chan range) = makeRequest r+ $ Get (url // chan /: "messages") (toQueryString range)+ go r@(GetChannelMessage chan msg) = makeRequest r+ $ Get (url // chan /: "messages" // msg) mempty+ go r@(CreateMessage chan msg embed) = makeRequest r+ $ Post (url // chan /: "messages")+ (ReqBodyJson . object $ ["content" .= msg] <> maybeEmbed embed)+ mempty+ go r@(UploadFile chan fileName file) = do+ body <- reqBodyMultipart [partFileRequestBody "file" fileName $ RequestBodyLBS file]+ makeRequest r $ Post (url // chan /: "messages")+ body mempty+ go r@(EditMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) new embed) = makeRequest r+ $ Patch (url // chan /: "messages" // msg)+ (ReqBodyJson . object $ ["content" .= new] <> maybeEmbed embed)+ mempty+ go r@(DeleteMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _)) = makeRequest r+ $ Delete (url // chan /: "messages" // msg) mempty+ go r@(BulkDeleteMessage chan msgs) = makeRequest r+ $ Post (url // chan /: "messages" /: "bulk-delete")+ (ReqBodyJson $ object ["messages" .= Prelude.map messageId msgs])+ mempty+ go r@(EditChannelPermissions chan perm patch) = makeRequest r+ $ Put (url // chan /: "permissions" // perm)+ (ReqBodyJson patch) mempty+ go r@(GetChannelInvites chan) = makeRequest r+ $ Get (url // chan /: "invites") mempty+ go r@(CreateChannelInvite chan patch) = makeRequest r+ $ Post (url // chan /: "invites")+ (ReqBodyJson patch) mempty+ go r@(DeleteChannelPermission chan perm) = makeRequest r+ $ Delete (url // chan /: "permissions" // perm) mempty+ go r@(TriggerTypingIndicator chan) = makeRequest r+ $ Post (url // chan /: "typing")+ NoReqBody mempty+ go r@(GetPinnedMessages chan) = makeRequest r+ $ Get (url // chan /: "pins") mempty+ go r@(AddPinnedMessage chan msg) = makeRequest r+ $ Put (url // chan /: "pins" // msg)+ NoReqBody mempty+ go r@(DeletePinnedMessage chan msg) = makeRequest r+ $ Delete (url // chan /: "pins" // msg) mempty
+ src/Network/Discord/Rest/Guild.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- | Provides actions for Guild API interactions.+module Network.Discord.Rest.Guild+ (+ GuildRequest(..)+ ) where++ import Data.Aeson+ import Data.Hashable+ import Data.Monoid (mempty)+ import Data.Text as T+ import Network.HTTP.Req ((=:))++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types+ import Network.Discord.Rest.HTTP++ -- | Data constructor for Guild requests. See+ -- <https://discordapp.com/developers/docs/resources/guild Guild API>+ data GuildRequest a where+ -- | Returns the new 'Guild' object for the given id+ GetGuild :: Snowflake -> GuildRequest Guild+ -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a+ -- Guild Update 'Event'.+ ModifyGuild :: ToJSON a => Snowflake -> a -> GuildRequest Guild+ -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'.+ DeleteGuild :: Snowflake -> GuildRequest Guild+ -- | Returns a list of guild 'Channel' objects+ GetGuildChannels :: Snowflake -> GuildRequest [Channel]+ -- | Create a new 'Channel' object for the guild. Requires 'MANAGE_CHANNELS'+ -- permission. Returns the new 'Channel' object on success. Fires a Channel Create+ -- 'Event'+ CreateGuildChannel :: ToJSON a => Snowflake -> a -> GuildRequest Channel+ -- | Modify the positions of a set of channel objects for the guild. Requires+ -- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel'+ -- objects on success. Fires multiple Channel Update 'Event's.+ ModifyChanPosition :: ToJSON a => Snowflake -> a -> GuildRequest [Channel]+ -- | Returns a guild 'Member' object for the specified user+ GetGuildMember :: Snowflake -> Snowflake -> GuildRequest Member+ -- | Returns a list of guild 'Member' objects that are members of the guild.+ ListGuildMembers :: Snowflake -> Range -> GuildRequest [Member]+ -- | Adds a user to the guild, provided you have a valid oauth2 access token+ -- for the user with the guilds.join scope. Returns the guild 'Member' as the body.+ -- Fires a Guild Member Add 'Event'. Requires the bot to have the+ -- CREATE_INSTANT_INVITE permission.+ AddGuildMember :: ToJSON a => Snowflake -> Snowflake -> a+ -> GuildRequest Member+ -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'.+ ModifyGuildMember :: ToJSON a => Snowflake -> Snowflake -> a+ -> GuildRequest ()+ -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a+ -- Guild Member Remove 'Event'.+ RemoveGuildMember :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Returns a list of 'User' objects that are banned from this guild. Requires the+ -- 'BAN_MEMBERS' permission+ GetGuildBans :: Snowflake -> GuildRequest [User]+ -- | Create a guild ban, and optionally Delete previous messages sent by the banned+ -- user. Requires the 'BAN_MEMBERS' permission. Fires a Guild Ban Add 'Event'.+ CreateGuildBan :: Snowflake -> Snowflake -> Integer -> GuildRequest ()+ -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions.+ -- Fires a Guild Ban Remove 'Event'.+ RemoveGuildBan :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES'+ -- permission+ GetGuildRoles :: Snowflake -> GuildRequest [Role]+ -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission.+ -- Returns the new role object on success. Fires a Guild Role Create 'Event'.+ CreateGuildRole :: Snowflake -> GuildRequest Role+ -- | Modify the positions of a set of role objects for the guild. Requires the+ -- 'MANAGE_ROLES' permission. Returns a list of all of the guild's 'Role' objects+ -- on success. Fires multiple Guild Role Update 'Event's.+ ModifyGuildRolePositions :: ToJSON a => Snowflake -> [a] -> GuildRequest [Role]+ -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the+ -- updated 'Role' on success. Fires a Guild Role Update 'Event's.+ ModifyGuildRole :: ToJSON a => Snowflake -> Snowflake -> a+ -> GuildRequest Role+ -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role+ -- Delete 'Event'.+ DeleteGuildRole :: Snowflake -> Snowflake -> GuildRequest Role+ -- | Returns an object with one 'pruned' key indicating the number of members+ -- that would be removed in a prune operation. Requires the 'KICK_MEMBERS'+ -- permission.+ GetGuildPruneCount :: Snowflake -> Integer -> GuildRequest Object+ -- | Begin a prune operation. Requires the 'KICK_MEMBERS' permission. Returns an+ -- object with one 'pruned' key indicating the number of members that were removed+ -- in the prune operation. Fires multiple Guild Member Remove 'Events'.+ BeginGuildPrune :: Snowflake -> Integer -> GuildRequest Object+ -- | Returns a list of 'VoiceRegion' objects for the guild. Unlike the similar /voice+ -- route, this returns VIP servers when the guild is VIP-enabled.+ GetGuildVoiceRegions :: Snowflake -> GuildRequest [VoiceRegion]+ -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD'+ -- permission.+ GetGuildInvites :: Snowflake -> GuildRequest [Invite]+ -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD'+ -- permission.+ GetGuildIntegrations :: Snowflake -> GuildRequest [Integration]+ -- | Attach an 'Integration' object from the current user to the guild. Requires the+ -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.+ CreateGuildIntegration :: ToJSON a => Snowflake -> a -> GuildRequest ()+ -- | Modify the behavior and settings of a 'Integration' object for the guild.+ -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.+ ModifyGuildIntegration :: ToJSON a => Snowflake -> Snowflake -> a -> GuildRequest ()+ -- | Delete the attached 'Integration' object for the guild. Requires the+ -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.+ DeleteGuildIntegration :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission.+ SyncGuildIntegration :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Returns the 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission.+ GetGuildEmbed :: Snowflake -> GuildRequest GuildEmbed+ -- | Modify a 'GuildEmbed' object for the guild. All attributes may be passed in with+ -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated+ -- 'GuildEmbed' object.+ ModifyGuildEmbed :: Snowflake -> GuildEmbed -> GuildRequest GuildEmbed++ instance Hashable (GuildRequest a) where+ hashWithSalt s (GetGuild g) = hashWithSalt s ("guild"::Text, g)+ hashWithSalt s (ModifyGuild g _) = hashWithSalt s ("guild"::Text, g)+ hashWithSalt s (DeleteGuild g) = hashWithSalt s ("guild"::Text, g)+ hashWithSalt s (GetGuildChannels g) = hashWithSalt s ("guild_chan"::Text, g)+ hashWithSalt s (CreateGuildChannel g _) = hashWithSalt s ("guild_chan"::Text, g)+ hashWithSalt s (ModifyChanPosition g _) = hashWithSalt s ("guild_chan"::Text, g)+ hashWithSalt s (GetGuildMember g _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (ListGuildMembers g _) = hashWithSalt s ("guild_membs"::Text, g)+ hashWithSalt s (AddGuildMember g _ _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (ModifyGuildMember g _ _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (RemoveGuildMember g _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (GetGuildBans g) = hashWithSalt s ("guild_bans"::Text, g)+ hashWithSalt s (CreateGuildBan g _ _) = hashWithSalt s ("guild_ban" ::Text, g)+ hashWithSalt s (RemoveGuildBan g _) = hashWithSalt s ("guild_ban" ::Text, g)+ hashWithSalt s (GetGuildRoles g) = hashWithSalt s ("guild_roles"::Text, g)+ hashWithSalt s (CreateGuildRole g) = hashWithSalt s ("guild_roles"::Text, g)+ hashWithSalt s (ModifyGuildRolePositions g _)+ = hashWithSalt s ("guild_roles"::Text, g)+ hashWithSalt s (ModifyGuildRole g _ _) = hashWithSalt s ("guild_role" ::Text, g)+ hashWithSalt s (DeleteGuildRole g _ ) = hashWithSalt s ("guild_role" ::Text, g)+ hashWithSalt s (GetGuildPruneCount g _) = hashWithSalt s ("guild_prune"::Text, g)+ hashWithSalt s (BeginGuildPrune g _) = hashWithSalt s ("guild_prune"::Text, g)+ hashWithSalt s (GetGuildVoiceRegions g) = hashWithSalt s ("guild_voice"::Text, g)+ hashWithSalt s (GetGuildInvites g) = hashWithSalt s ("guild_invit"::Text, g)+ hashWithSalt s (GetGuildIntegrations g) = hashWithSalt s ("guild_integ"::Text, g)+ hashWithSalt s (CreateGuildIntegration g _)+ = hashWithSalt s ("guild_integ"::Text, g)+ hashWithSalt s (ModifyGuildIntegration g _ _)+ = hashWithSalt s ("guild_intgr"::Text, g)+ hashWithSalt s (DeleteGuildIntegration g _)+ = hashWithSalt s ("guild_intgr"::Text, g)+ hashWithSalt s (SyncGuildIntegration g _)= hashWithSalt s ("guild_sync" ::Text, g)+ hashWithSalt s (GetGuildEmbed g) = hashWithSalt s ("guild_embed"::Text, g)+ hashWithSalt s (ModifyGuildEmbed g _) = hashWithSalt s ("guild_embed"::Text, g)++ instance (FromJSON a) => DoFetch GuildRequest a where+ doFetch = go+ where+ url = baseUrl /: "guilds"+ go :: DiscordRest m => GuildRequest a -> m a+ go r@(GetGuild guild) = makeRequest r+ $ Get (url // guild) mempty+ go r@(ModifyGuild guild patch) = makeRequest r+ $ Patch (url // guild) (ReqBodyJson patch) mempty+ go r@(DeleteGuild guild) = makeRequest r+ $ Delete (url // guild) mempty+ go r@(GetGuildChannels guild) = makeRequest r+ $ Get (url // guild /: "channels") mempty+ go r@(CreateGuildChannel guild patch) = makeRequest r+ $ Post (url // guild /: "channels") (ReqBodyJson patch) mempty+ go r@(ModifyChanPosition guild patch) = makeRequest r+ $ Post (url // guild /: "channels") (ReqBodyJson patch) mempty+ go r@(GetGuildMember guild member) = makeRequest r+ $ Get (url // guild /: "members" // member) mempty+ go r@(ListGuildMembers guild range) = makeRequest r+ $ Get (url // guild /: "members") (toQueryString range)+ go r@(AddGuildMember guild user patch) = makeRequest r+ $ Put (url // guild /: "members" // user) (ReqBodyJson patch) mempty+ go r@(ModifyGuildMember guild member patch) = makeRequest r+ $ Patch (url // guild /: "members" // member) (ReqBodyJson patch) mempty+ go r@(RemoveGuildMember guild user) = makeRequest r+ $ Delete (url // guild /: "members" // user) mempty+ go r@(GetGuildBans guild) = makeRequest r+ $ Get (url // guild /: "bans") mempty+ go r@(CreateGuildBan guild user msgs) = makeRequest r+ $ Put (url // guild /: "bans" // user)+ (ReqBodyJson $ object [ "delete-message-days" .= msgs])+ mempty+ go r@(RemoveGuildBan guild ban) = makeRequest r+ $ Delete (url // guild /: "bans" // ban) mempty+ go r@(GetGuildRoles guild) = makeRequest r+ $ Get (url // guild /: "roles") mempty+ go r@(CreateGuildRole guild) = makeRequest r+ $ Post (url // guild /: "roles")+ NoReqBody mempty+ go r@(ModifyGuildRolePositions guild patch) = makeRequest r+ $ Post (url // guild /: "roles")+ (ReqBodyJson patch) mempty+ go r@(ModifyGuildRole guild role patch) = makeRequest r+ $ Post (url // guild /: "roles" // role)+ (ReqBodyJson patch) mempty+ go r@(DeleteGuildRole guild role) = makeRequest r+ $ Delete (url // guild /: "roles" // role) mempty+ go r@(GetGuildPruneCount guild days) = makeRequest r+ $ Get (url // guild /: "prune") ("days" =: days)+ go r@(BeginGuildPrune guild days) = makeRequest r+ $ Post (url // guild /: "prune")+ NoReqBody ("days" =: days)+ go r@(GetGuildVoiceRegions guild) = makeRequest r+ $ Get (url // guild /: "regions") mempty+ go r@(GetGuildInvites guild) = makeRequest r+ $ Get (url // guild /: "invites") mempty+ go r@(GetGuildIntegrations guild) = makeRequest r+ $ Get (url // guild /: "integrations") mempty+ go r@(CreateGuildIntegration guild patch) = makeRequest r+ $ Post (url // guild /: "integrations")+ (ReqBodyJson patch) mempty+ go r@(ModifyGuildIntegration guild integ patch) = makeRequest r+ $ Patch (url // guild /: "integrations" // integ)+ (ReqBodyJson patch) mempty+ go r@(DeleteGuildIntegration guild integ) = makeRequest r+ $ Delete (url // guild /: "integrations" // integ)+ mempty+ go r@(SyncGuildIntegration guild integ) = makeRequest r+ $ Post (url // guild /: "integrations" // integ)+ NoReqBody mempty+ go r@(GetGuildEmbed guild) = makeRequest r+ $ Get (url // guild /: "integrations") mempty+ go r@(ModifyGuildEmbed guild patch) = makeRequest r+ $ Patch (url // guild /: "embed")+ (ReqBodyJson patch) mempty
+ src/Network/Discord/Rest/HTTP.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds, ScopedTypeVariables, Rank2Types #-}+-- | Provide HTTP primitives+module Network.Discord.Rest.HTTP+ ( JsonRequest(..)+ , R.ReqBodyJson(..)+ , R.NoReqBody(..)+ , baseUrl+ , fetch+ , makeRequest+ , (//)+ , (R./:)+ ) where++ import Data.Semigroup ((<>))++ import Control.Monad (when)+ import Data.Aeson+ import Data.ByteString.Char8 (pack, ByteString)+ import Data.Hashable+ import Data.Maybe (fromMaybe)+ import qualified Data.Text as T (pack)+ import qualified Network.HTTP.Req as R++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types++ -- | The base url (Req) for API requests+ baseUrl :: R.Url 'R.Https+ baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion+ where apiVersion = "v6"++ -- | Construct base options with auth from Discord state+ baseRequestOptions :: DiscordRest m => m Option+ baseRequestOptions = do+ a <- auth+ v <- version+ return $ R.header "Authorization" (pack . show $ a)+ <> R.header "User-Agent" (pack $ "DiscordBot (https://github.com/jano017/Discord.hs,"+ ++ v ++ ")")+ infixl 5 //+ (//) :: Show a => R.Url scheme -> a -> R.Url scheme+ url // part = url R./: (T.pack $ show part)++ type Option = R.Option 'R.Https++ -- | Represtents a HTTP request made to an API that supplies a Json response+ data JsonRequest r where+ Delete :: FromJSON r => R.Url 'R.Https -> Option -> JsonRequest r+ Get :: FromJSON r => R.Url 'R.Https -> Option -> JsonRequest r+ Patch :: (FromJSON r, R.HttpBody a) => R.Url 'R.Https -> a -> Option -> JsonRequest r+ Post :: (FromJSON r, R.HttpBody a) => R.Url 'R.Https -> a -> Option -> JsonRequest r+ Put :: (FromJSON r, R.HttpBody a) => R.Url 'R.Https -> a -> Option -> JsonRequest r++ fetch :: (FromJSON r, DiscordRest m) => JsonRequest r -> m (R.JsonResponse r)+ fetch (Delete url opts) = R.req R.DELETE url R.NoReqBody R.jsonResponse =<< (<> opts) <$> baseRequestOptions+ fetch (Get url opts) = R.req R.GET url R.NoReqBody R.jsonResponse =<< (<> opts) <$> baseRequestOptions+ fetch (Patch url body opts) = R.req R.PATCH url body R.jsonResponse =<< (<> opts) <$> baseRequestOptions+ fetch (Post url body opts) = R.req R.POST url body R.jsonResponse =<< (<> opts) <$> baseRequestOptions+ fetch (Put url body opts) = R.req R.PUT url body R.jsonResponse =<< (<> opts) <$> baseRequestOptions++ makeRequest :: (FromJSON r, DiscordRest m, DoFetch f r) + => f r -> JsonRequest r -> m r+ makeRequest req action = do+ waitRateLimit req+ resp <- fetch action+ when (parseHeader resp "X-RateLimit-Remaining" 1 < 1) $+ setRateLimit req $ parseHeader resp "X-RateLimit-Reset" 0+ return $ R.responseBody resp+ where+ parseHeader :: R.HttpResponse resp => resp -> ByteString -> Int -> Int+ parseHeader resp header def = fromMaybe def $ decodeStrict =<< R.responseHeader resp header++ instance Hashable (JsonRequest r) where+ hashWithSalt s (Delete url _) = hashWithSalt s $ show url+ hashWithSalt s (Get url _) = hashWithSalt s $ show url+ hashWithSalt s (Patch url _ _) = hashWithSalt s $ show url+ hashWithSalt s (Post url _ _) = hashWithSalt s $ show url+ hashWithSalt s (Put url _ _) = hashWithSalt s $ show url+ + -- | Base implementation of DoFetch, allows arbitrary HTTP requests to be performed+ instance (FromJSON r) => DoFetch JsonRequest r where+ doFetch req = R.responseBody <$> fetch req
+ src/Network/Discord/Rest/Prelude.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds, OverloadedStrings, MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies, KindSignatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Utility and base types and functions for the Discord Rest API+module Network.Discord.Rest.Prelude where+ import Control.Concurrent (threadDelay)+ import Control.Monad (when)+ import Control.Exception (throwIO)++ import Control.Monad.IO.Class+ import Data.Default+ import Data.Hashable+ import Data.Monoid ((<>))+ import Data.Time.Clock.POSIX+ import Network.HTTP.Req (Option, Scheme(..), (=:), MonadHttp(..))+ import System.Log.Logger++ import Network.Discord.Types++ -- | The base url for API requests+ baseURL :: String+ baseURL = "https://discordapp.com/api/v6"++ class (MonadIO m, DiscordAuth m) => DiscordRest m where+ getRateLimit :: DoFetch f a => f a -> m (Maybe Int)++ setRateLimit :: DoFetch f a => f a -> Int -> m ()++ waitRateLimit :: DoFetch f a => f a -> m ()+ waitRateLimit endpoint = do+ rl <- getRateLimit endpoint+ case rl of+ Nothing -> return ()+ Just l -> do+ now <- liftIO (fmap round getPOSIXTime :: IO Int)+ when (l > now) . liftIO $ do+ infoM "Discord-hs.Rest" "Hit rate limit, backing off"+ threadDelay $ 1000000 * (l - now)+ infoM "Discord-hs.Rest" "Done waiting"+ return ()++ instance (MonadIO m, DiscordRest m) => MonadHttp m where+ handleHttpException = liftIO . throwIO++ -- | Class over which performing a data retrieval action is defined+ class Hashable (a b) => DoFetch (a :: * -> *) b | a b -> b where+ doFetch :: DiscordRest m => a b -> m b+ + -- | Represents a range of 'Snowflake's+ data Range = Range { after :: Snowflake, before :: Snowflake, limit :: Int}++ instance Default Range where+ def = Range 0 18446744073709551615 100+ + -- | Convert a Range to a query string+ toQueryString :: Range -> Option 'Https+ toQueryString (Range a b l)+ = "after" =: show a + <> "before" =: show b + <> "limit" =: show l
+ src/Network/Discord/Rest/User.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- | Provide actions for User API interactions.+module Network.Discord.Rest.User+ (+ UserRequest(..)+ ) where++ import Data.Aeson+ import Data.Hashable+ import Data.Monoid (mempty)+ import Data.Text as T++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types+ import Network.Discord.Rest.HTTP++ -- | Data constructor for User requests. See+ -- <https://discordapp.com/developers/docs/resources/user User API>+ data UserRequest a where+ -- | Returns the 'User' object of the requester's account. For OAuth2, this requires+ -- the identify scope, which will return the object without an email, and optionally+ -- the email scope, which returns the object with an email.+ GetCurrentUser :: UserRequest User+ -- | Returns a 'User' for a given user ID+ GetUser :: Snowflake -> UserRequest User+ -- | Modify the requestors user account settings. Returns a 'User' object on success.+ ModifyCurrentUser :: ToJSON a => a -> UserRequest User+ -- | Returns a list of user 'Guild' objects the current user is a member of.+ -- Requires the guilds OAuth2 scope.+ GetCurrentUserGuilds :: Range -> UserRequest Guild+ -- | Leave a guild.+ LeaveGuild :: Snowflake -> UserRequest ()+ -- | Returns a list of DM 'Channel' objects+ GetUserDMs :: UserRequest [Channel]+ -- | Create a new DM channel with a user. Returns a DM 'Channel' object.+ CreateDM :: Snowflake -> UserRequest Channel++ instance Hashable (UserRequest a) where+ hashWithSalt s (GetCurrentUser) = hashWithSalt s ("me"::Text)+ hashWithSalt s (GetUser _) = hashWithSalt s ("user"::Text)+ hashWithSalt s (ModifyCurrentUser _) = hashWithSalt s ("modify_user"::Text)+ hashWithSalt s (GetCurrentUserGuilds _) = hashWithSalt s ("get_user_guilds"::Text)+ hashWithSalt s (LeaveGuild g) = hashWithSalt s ("leave_guild"::Text, g)+ hashWithSalt s (GetUserDMs) = hashWithSalt s ("get_dms"::Text)+ hashWithSalt s (CreateDM _) = hashWithSalt s ("make_dm"::Text)++ instance (FromJSON a) => DoFetch UserRequest a where+ doFetch = go+ where+ url = baseUrl /: "users"+ go :: DiscordRest m => UserRequest a -> m a+ go r@(GetCurrentUser) = makeRequest r+ $ Get (url /: "@me") mempty++ go r@(GetUser user) = makeRequest r+ $ Get (url // user ) mempty++ go r@(ModifyCurrentUser patch) = makeRequest r+ $ Patch (url /: "@me") (ReqBodyJson patch) mempty++ go r@(GetCurrentUserGuilds range) = makeRequest r+ $ Get url $ toQueryString range++ go r@(LeaveGuild guild) = makeRequest r+ $ Delete (url /: "@me" /: "guilds" // guild) mempty++ go r@(GetUserDMs) = makeRequest r+ $ Get (url /: "@me" /: "channels") mempty++ go r@(CreateDM user) = makeRequest r+ $ Post (url /: "@me" /: "channels")+ (ReqBodyJson $ object ["recipient_id" .= user])+ mempty