diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# discord-haskell [![CI Status](https://github.com/aquarial/discord-haskell/actions/workflows/main.yml/badge.svg)](https://github.com/aquarial/discord-haskell/actions/) [![Hackage version](http://img.shields.io/hackage/v/discord-haskell.svg?label=Hackage)](https://hackage.haskell.org/package/discord-haskell) [![Discord server](https://discord.com/api/guilds/918577626954739722/widget.png?style=shield)](https://discord.gg/eaRAGgX3bK) +# discord-haskell [![CI Status](https://github.com/discord-haskell/discord-haskell/actions/workflows/main.yml/badge.svg)](https://github.com/discord-haskell/discord-haskell/actions/) [![Hackage version](http://img.shields.io/hackage/v/discord-haskell.svg?label=Hackage)](https://hackage.haskell.org/package/discord-haskell) [![Discord server](https://discord.com/api/guilds/918577626954739722/widget.png?style=shield)](https://discord.gg/eaRAGgX3bK) Build that discord bot in Haskell! Also checkout the diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,26 +1,36 @@ # Changelog -View on github for newest version: https://github.com/aquarial/discord-haskell/blob/master/changelog.md +View on github for newest version: https://github.com/discord-haskell/discord-haskell/blob/master/changelog.md Discord API changes, so use the most recent version at all times ## master +## 1.14.0 + +[yutotakano](https://github.com/discord-haskell/discord-haskell/pull/124) Replace JuicyPixels image parsing with a mimetype check. Make image handling consistent: use `parseStickerImage` fro sticker images. Use `parseAvatarImage` for avatars. + +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/123/files) Make webhook API smaller, each constructor takes in a `Maybe WebhookToken`. Passing `Nothing` will continue to work as normal. + +[Annwan](https://github.com/discord-haskell/discord-haskell/pull/123) Huge documentation flourish. Removed deprecated AppCommandPermissions func & fix presences typo + +[yutotakano](https://github.com/discord-haskell/discord-haskell/pull/121) Replace `OverwriteId` with `Either RoleId UserId` in `ChannelPermission` requests, and remove the `type` field from `ChannelPermissionsOpts` + ## 1.13.0 -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/117) Shorten ApplicationCommand names! To update search [the pull-request](https://github.com/aquarial/discord-haskell/pull/117/files) for what the names are replaced with +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/117) Shorten ApplicationCommand names! To update search [the pull-request](https://github.com/discord-haskell/discord-haskell/pull/117/files) for what the names are replaced with -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/116) Typesafe Snowflakes (guildid, channelid, userid, etcid) +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/116) Typesafe Snowflakes (guildid, channelid, userid, etcid) -Improve `restCall` type error messages https://github.com/aquarial/discord-haskell/issues/102 +Improve `restCall` type error messages https://github.com/discord-haskell/discord-haskell/issues/102 ## 1.12.5 -[Annwan](https://github.com/aquarial/discord-haskell/pull/109) Add `ScheduledEvent` rest API +[Annwan](https://github.com/discord-haskell/discord-haskell/pull/109) Add `ScheduledEvent` rest API -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/110) Add stickers API +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/110) Add stickers API -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/111) Add ModifyGuildMember 'timeout' option +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/111) Add ModifyGuildMember 'timeout' option ## 1.12.4 @@ -32,35 +42,35 @@ ## 1.12.2 -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/107) `EditMessage` takes full `MessageDetailedOpts` (instead of Embed) +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/107) `EditMessage` takes full `MessageDetailedOpts` (instead of Embed) Removed `CreateMessageUploadFile` (use `CreateMessageDetailed { MessageDetailedOpts { messageDetailedFile } }`) ## 1.12.1 -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/103) Add threads, switch api to V10, Update Guild data fields +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/103) Add threads, switch api to V10, Update Guild data fields -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/104) Add model interaction and components +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/104) Add model interaction and components ## 1.12.0 -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/96) breaking changes and fixes to application commands, interactions, and components, and updates elsewhere +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/96) breaking changes and fixes to application commands, interactions, and components, and updates elsewhere ## 1.11.0 -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/88) did a LOT of work wrangling the discord API for interactions and commands! +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/88) did a LOT of work wrangling the discord API for interactions and commands! -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/94) fixed a parse error with webhooktoken +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/94) fixed a parse error with webhooktoken rename fields `messageText` -> `messageContent`, `messageChannel` -> `messageChannelId` ## 1.10.0 -[drewolson](https://github.com/aquarial/discord-haskell/pull/80) allows parsing an optional guild region +[drewolson](https://github.com/discord-haskell/discord-haskell/pull/80) allows parsing an optional guild region -[L0neGamer](https://github.com/aquarial/discord-haskell/pull/82) add 'animated' flag for Emoji +[L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/82) add 'animated' flag for Emoji Removed `CreateGuild` rest call! You can only do it if your bot is in fewer than 10 guilds, and it's [a pain to support](https://discord.com/developers/docs/resources/guild#create-guild). Just do it manually. @@ -68,60 +78,60 @@ ## 1.9.1 -Add [color attribute for CreateEmbed](https://github.com/aquarial/discord-haskell/issues/78) +Add [color attribute for CreateEmbed](https://github.com/discord-haskell/discord-haskell/issues/78) -Rewrite [EventLoop.hs](https://github.com/aquarial/discord-haskell/issues/70) to be easier to modify +Rewrite [EventLoop.hs](https://github.com/discord-haskell/discord-haskell/issues/70) to be easier to modify Rename a bunch of internal handles so they have more consistent names ## 1.8.9 -Handle both aeson 1.0 and 2.0 [(breaking changes broke builds)](https://github.com/aquarial/discord-haskell/issues/77) +Handle both aeson 1.0 and 2.0 [(breaking changes broke builds)](https://github.com/discord-haskell/discord-haskell/issues/77) -Simplify [some examples](https://github.com/aquarial/discord-haskell/issues/71) +Simplify [some examples](https://github.com/discord-haskell/discord-haskell/issues/71) ## 1.8.8 -Remove git artifacts from [examples/ping-pong.hs](https://github.com/aquarial/discord-haskell/issues/69) +Remove git artifacts from [examples/ping-pong.hs](https://github.com/discord-haskell/discord-haskell/issues/69) ## 1.8.7 -Add [Stage channel](https://github.com/aquarial/discord-haskell/issues/68) and a catch-all Unknown channel so we stop crashing on new releases (?) +Add [Stage channel](https://github.com/discord-haskell/discord-haskell/issues/68) and a catch-all Unknown channel so we stop crashing on new releases (?) ## 1.8.6 -Add [missing fields](https://github.com/aquarial/discord-haskell/issues/67) to ChannelGuildCategory +Add [missing fields](https://github.com/discord-haskell/discord-haskell/issues/67) to ChannelGuildCategory ## 1.8.5 - Fix examples/ping-pong.hs compilation error https://github.com/aquarial/discord-haskell/issues/65 + Fix examples/ping-pong.hs compilation error https://github.com/discord-haskell/discord-haskell/issues/65 ## 1.8.4 -[yutotakano](https://github.com/aquarial/discord-haskell/pull/64) Added discord replies type, and message constructor +[yutotakano](https://github.com/discord-haskell/discord-haskell/pull/64) Added discord replies type, and message constructor ## 1.8.3 -Bot no longer disconnects randomly (hopefully) https://github.com/aquarial/discord-haskell/issues/62 +Bot no longer disconnects randomly (hopefully) https://github.com/discord-haskell/discord-haskell/issues/62 ## 1.8.2 -Added 'Competing' activity https://github.com/aquarial/discord-haskell/issues/61 +Added 'Competing' activity https://github.com/discord-haskell/discord-haskell/issues/61 -Resend the last Activity settings on Resume fixing https://github.com/aquarial/discord-haskell/issues/60 +Resend the last Activity settings on Resume fixing https://github.com/discord-haskell/discord-haskell/issues/60 ## 1.8.1 -Added `MessageReaction` to Message https://github.com/aquarial/discord-haskell/issues/56 +Added `MessageReaction` to Message https://github.com/discord-haskell/discord-haskell/issues/56 ## 1.8.0 -Fixed [null parent_id on channel](https://github.com/aquarial/discord-haskell/issues/55) +Fixed [null parent_id on channel](https://github.com/discord-haskell/discord-haskell/issues/55) ## 1.7.0 -[elikoga](https://github.com/aquarial/discord-haskell/pull/51) Changed to use `ReaderT` interface +[elikoga](https://github.com/discord-haskell/discord-haskell/pull/51) Changed to use `ReaderT` interface -[elikoga](https://github.com/aquarial/discord-haskell/pull/50) Fixed compiler warnings +[elikoga](https://github.com/discord-haskell/discord-haskell/pull/50) Fixed compiler warnings Changed api url to new `discord.com` @@ -129,7 +139,7 @@ Changed discordapp.com to discord.com in accordance with official discord policy -[rexim](https://github.com/aquarial/discord-haskell/pull/41) Add `Emoji.user` field. Who uploaded the emoji +[rexim](https://github.com/discord-haskell/discord-haskell/pull/41) Add `Emoji.user` field. Who uploaded the emoji ## 1.6.0 @@ -143,7 +153,7 @@ ## 1.5.0 -[rexim](https://github.com/aquarial/discord-haskell/pull/35) Add `Read` instance for `Snowflake` +[rexim](https://github.com/discord-haskell/discord-haskell/pull/35) Add `Read` instance for `Snowflake` ## 1.4.0 @@ -151,11 +161,11 @@ 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) +`CreateEmbedImageUpload` implementation inspired by [Flutterlice](https://github.com/discord-haskell/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 +[PixeLinc](https://github.com/discord-haskell/discord-haskell/pull/33) Add `DeleteSingleReaction` rest-request, Add GuildId to `ReactinInfo`, Add `MESSAGE_REACTION_REMOVE_EMOJI` gateway event `GetReactions` actually returns the User objects request @@ -165,13 +175,13 @@ ## 1.2.0 -[MDeltaX](https://github.com/aquarial/discord-haskell/pull/27) Fixed typo: depreciated --> deprecated +[MDeltaX](https://github.com/discord-haskell/discord-haskell/pull/27) Fixed typo: depreciated --> deprecated -[MDeltaX](https://github.com/aquarial/discord-haskell/pull/29) More consistency: RoleID --> RoleId +[MDeltaX](https://github.com/discord-haskell/discord-haskell/pull/29) More consistency: RoleID --> RoleId -[MDeltaX](https://github.com/aquarial/discord-haskell/pull/29) Fix ModifyGuildRole: Post --> Patch && optional args +[MDeltaX](https://github.com/discord-haskell/discord-haskell/pull/29) Fix ModifyGuildRole: Post --> Patch && optional args -[Hippu](https://github.com/aquarial/discord-haskell/pull/31) Won't crash on integer-nonces in ChannelMessage-events (usually strings) +[Hippu](https://github.com/discord-haskell/discord-haskell/pull/31) Won't crash on integer-nonces in ChannelMessage-events (usually strings) ## 1.1.3 @@ -179,7 +189,7 @@ ## 1.1.2 -[michalrus](https://github.com/aquarial/discord-haskell/issues/25) Fix `DeleteGuildRole` parse exception +[michalrus](https://github.com/discord-haskell/discord-haskell/issues/25) Fix `DeleteGuildRole` parse exception ## 1.1.1 @@ -193,14 +203,14 @@ Going through some major updates to the library. Expect types to change and things to break. -Compare the [old ping-pong](https://github.com/aquarial/discord-haskell/blob/20f7f8556823a754c76d01484118a5abf336530b/examples/ping-pong.hs) -to the [new ping-pong](https://github.com/aquarial/discord-haskell/blob/7eaa6ca068f945603de7f43f6f270c2dbecd3c85/examples/ping-pong.hs) +Compare the [old ping-pong](https://github.com/discord-haskell/discord-haskell/blob/20f7f8556823a754c76d01484118a5abf336530b/examples/ping-pong.hs) +to the [new ping-pong](https://github.com/discord-haskell/discord-haskell/blob/7eaa6ca068f945603de7f43f6f270c2dbecd3c85/examples/ping-pong.hs) Added a few rest ADT types ## 0.8.4 -[marcotoniut](https://github.com/aquarial/discord-haskell/pull/18) Improved changed Embed ADT to have optional fields, and improved two field names +[marcotoniut](https://github.com/discord-haskell/discord-haskell/pull/18) Improved changed Embed ADT to have optional fields, and improved two field names Add `ModifyGuildMember`, `AddGuildMember`, `AddGuildMemberRole`, `AddGuildMemberRole`, `RemoveGuildmembeRole`, `GetGuildBan`, `GetGuildVanityURL` rest data types @@ -214,11 +224,11 @@ Hardcode CreateReaction delay so bots can add reactions 4 times faster -[MP2E](https://github.com/aquarial/discord-haskell/pull/14) Fixed parse error on GuildBanAdd + GuildBanRevoke: user\_object instead the whole object +[MP2E](https://github.com/discord-haskell/discord-haskell/pull/14) Fixed parse error on GuildBanAdd + GuildBanRevoke: user\_object instead the whole object ### 0.8.1 -[MP2E](https://github.com/aquarial/discord-haskell/pull/11) Fixed parse error on GuildRoleDelete: role_id instead of role +[MP2E](https://github.com/discord-haskell/discord-haskell/pull/11) Fixed parse error on GuildRoleDelete: role_id instead of role ### 0.8.0 @@ -236,13 +246,13 @@ ### 0.7.1 -[t1m0thyj](https://github.com/aquarial/discord-haskell/pull/6/files) Typo in RequestGuildMemberOpts fields fixed. +[t1m0thyj](https://github.com/discord-haskell/discord-haskell/pull/6/files) Typo in RequestGuildMemberOpts fields fixed. -[t1m0thyj](https://github.com/aquarial/discord-haskell/pull/6/files) Added Activity, ActivityType ADT +[t1m0thyj](https://github.com/discord-haskell/discord-haskell/pull/6/files) Added Activity, ActivityType ADT UpdateStatusTypes became UpdateStatusType (singular ADT) -[t1m0thyj](https://github.com/aquarial/discord-haskell/pull/7) Retry connection on 1001 websocket close +[t1m0thyj](https://github.com/discord-haskell/discord-haskell/pull/7) Retry connection on 1001 websocket close ### 0.7.0 diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,15 +1,15 @@ cabal-version: 2.0 name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 1.13.0 +version: 1.14.0 description: Functions and data types to write discord bots. Official discord docs . . See the project readme for quickstart notes - + synopsis: Write bots for Discord in Haskell -homepage: https://github.com/aquarial/discord-haskell -bug-reports: https://github.com/aquarial/discord-haskell/issues +homepage: https://github.com/discord-haskell/discord-haskell +bug-reports: https://github.com/discord-haskell/discord-haskell/issues license: MIT license-file: LICENSE author: Karl @@ -22,7 +22,7 @@ source-repository head type: git - location: https://github.com/aquarial/discord-haskell.git + location: https://github.com/discord-haskell/discord-haskell.git executable ping-pong main-is: examples/ping-pong.hs @@ -52,60 +52,60 @@ -fno-warn-type-defaults -fno-warn-unused-record-wildcards -Wunused-packages hs-source-dirs: src default-language: Haskell2010 - -- extensions: - exposed-modules: Discord - , Discord.Types - , Discord.Handle - , Discord.Interactions - , Discord.Requests - , Discord.Internal.Gateway - , Discord.Internal.Gateway.Cache - , Discord.Internal.Gateway.EventLoop - , Discord.Internal.Rest - , Discord.Internal.Rest.Prelude - , Discord.Internal.Rest.HTTP - , Discord.Internal.Rest.Invite - , Discord.Internal.Rest.Emoji - , Discord.Internal.Rest.User - , Discord.Internal.Rest.Guild - , Discord.Internal.Rest.Channel - , Discord.Internal.Rest.Voice - , Discord.Internal.Rest.Webhook - , Discord.Internal.Rest.ApplicationCommands - , Discord.Internal.Rest.Interactions - , Discord.Internal.Types - , Discord.Internal.Types.Prelude - , Discord.Internal.Types.Channel - , Discord.Internal.Types.Events - , Discord.Internal.Types.Gateway - , Discord.Internal.Types.Guild - , Discord.Internal.Types.User - , Discord.Internal.Types.Embed - , Discord.Internal.Types.ApplicationCommands - , Discord.Internal.Types.Interactions - , Discord.Internal.Types.Components - , Discord.Internal.Types.Color - , Discord.Internal.Types.Emoji - , Discord.Internal.Types.ScheduledEvents + exposed-modules: + Discord + , Discord.Types + , Discord.Handle + , Discord.Interactions + , Discord.Requests + , Discord.Internal.Gateway + , Discord.Internal.Gateway.Cache + , Discord.Internal.Gateway.EventLoop + , Discord.Internal.Rest + , Discord.Internal.Rest.Prelude + , Discord.Internal.Rest.HTTP + , Discord.Internal.Rest.Invite + , Discord.Internal.Rest.Emoji + , Discord.Internal.Rest.User + , Discord.Internal.Rest.Guild + , Discord.Internal.Rest.Channel + , Discord.Internal.Rest.Voice + , Discord.Internal.Rest.Webhook + , Discord.Internal.Rest.ApplicationCommands + , Discord.Internal.Rest.Interactions + , Discord.Internal.Types + , Discord.Internal.Types.Prelude + , Discord.Internal.Types.Channel + , Discord.Internal.Types.Events + , Discord.Internal.Types.Gateway + , Discord.Internal.Types.Guild + , Discord.Internal.Types.User + , Discord.Internal.Types.Embed + , Discord.Internal.Types.ApplicationCommands + , Discord.Internal.Types.Interactions + , Discord.Internal.Types.Components + , Discord.Internal.Types.Color + , Discord.Internal.Types.Emoji + , Discord.Internal.Types.ScheduledEvents build-depends: - base >= 4 && <5 - , aeson - , async - , bytestring - , base64-bytestring - , containers - , data-default - , emoji == 0.1.0.2 - , http-client - , iso8601-time - , MonadRandom - , req - , JuicyPixels - , safe-exceptions - , text - , time - , websockets - , wuss - , mtl - , unliftio - , scientific + base ==4.*, + aeson >=1.5 && <1.6, + async >=2.2 && <2.3, + bytestring >=0.10 && <0.11, + base64-bytestring >=1.1 && <1.2, + containers >=0.6 && <0.7, + data-default >=0.7 && <0.8, + emoji ==0.1.*, + http-client >=0.6 && <0.7, + iso8601-time >=0.1 && <0.2, + MonadRandom >=0.5 && <0.6, + req >=3.9 && <3.10, + safe-exceptions >=0.1 && <0.2, + text >=1.2 && <1.3, + time >=1.9 && <1.10, + websockets >=0.12 && <0.13, + wuss >=1.1 && <1.2, + mtl >=2.2 && <2.3, + unliftio >=0.2 && <0.3, + scientific >=0.3 && <0.4, + http-api-data >=0.4 && <0.5 diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text +import System.Exit (exitSuccess) import Control.Monad (when, forM_, void) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -13,9 +14,7 @@ -- Allows this code to be an executable. See discord-haskell.cabal main :: IO () -main = if testserverid == -1 - then TIO.putStrLn "ERROR: modify the source and set testserverid to your serverid" - else pingpongExample +main = pingpongExample @@ -28,6 +27,10 @@ -- | Replies "pong" to every message that starts with "ping" pingpongExample :: IO () pingpongExample = do + when (testserverid == (-1 :: GuildId)) $ do + TIO.putStrLn "ERROR: modify the source and set testserverid to your serverid" + exitSuccess + tok <- TIO.readFile "./examples/auth-token.secret" -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields @@ -36,7 +39,7 @@ , discordOnEnd = liftIO $ threadDelay (round (0.4 * 10^6)) >> putStrLn "Ended" , discordOnEvent = eventHandler , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" - , discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPrecenses =True} + , discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPresences =True} } -- only reached on an unrecoverable error diff --git a/src/Discord.hs b/src/Discord.hs --- a/src/Discord.hs +++ b/src/Discord.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Main module of the library +-- Contains all the entrypoints module Discord ( runDiscord , restCall @@ -21,6 +23,7 @@ ) where import Prelude hiding (log) +import Control.Exception (Exception) import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever) import Data.Aeson (FromJSON) import Data.Default (Default, def) @@ -36,18 +39,36 @@ import Discord.Internal.Rest.User (UserRequest(GetCurrentUser)) import Discord.Internal.Gateway +-- | A `ReaderT` wrapper around `DiscordHandle` and `IO`. Most functions act in +-- this monad type DiscordHandler = ReaderT DiscordHandle IO +-- | Options for the connection. data RunDiscordOpts = RunDiscordOpts - { discordToken :: T.Text - , discordOnStart :: DiscordHandler () - , discordOnEnd :: IO () - , discordOnEvent :: Event -> DiscordHandler () - , discordOnLog :: T.Text -> IO () - , discordForkThreadForEvents :: Bool - , discordGatewayIntent :: GatewayIntent + { -- | Token for the discord API + discordToken :: T.Text + , -- | Actions executed right after a connexion to discord's API is + -- established + discordOnStart :: DiscordHandler () + , -- | Actions executed at termination. + -- + -- Note that this runs in plain `IO` and not in `DiscordHandler` as the + -- connexion has been closed before this runs. + -- + -- Useful for cleaning up. + discordOnEnd :: IO () + , -- | Actions run upon the reception of an `Event`. This is here most of the + -- code of the bot may get dispatched from. + discordOnEvent :: Event -> DiscordHandler () + , -- | Dispatching on internal logs + discordOnLog :: T.Text -> IO () + , -- | Fork a thread for every `Event` recived + discordForkThreadForEvents :: Bool + , -- | The gateway intents the bot is asking for + discordGatewayIntent :: GatewayIntent } +-- | Default values for `RunDiscordOpts` instance Default RunDiscordOpts where def = RunDiscordOpts { discordToken = "" , discordOnStart = pure () @@ -58,6 +79,7 @@ , discordGatewayIntent = def } +-- | Entrypoint to the library runDiscord :: RunDiscordOpts -> IO T.Text runDiscord opts = do log <- newChan @@ -84,6 +106,7 @@ finally (runDiscordLoop handle opts) (discordOnEnd opts >> runReaderT stopDiscord handle) +-- | Runs the main loop runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text runDiscordLoop handle opts = do resp <- liftIO $ writeRestCall (discordHandleRestChan handle) GetCurrentUser @@ -119,10 +142,12 @@ Right _ -> pure () loop - +-- | A Error code following a rest call data RestCallErrorCode = RestCallErrorCode Int T.Text T.Text deriving (Show, Read, Eq, Ord) +instance Exception RestCallErrorCode + -- | Execute one http request and get a response restCall :: (Request (r a), FromJSON a) => r a -> DiscordHandler (Either RestCallErrorCode a) restCall r = do h <- ask @@ -174,6 +199,7 @@ HandleThreadIdCache a -> a HandleThreadIdLogger a -> a +-- | Starts the internal logger startLogger :: (T.Text -> IO ()) -> Chan T.Text -> IO ThreadId startLogger handle logC = forkIO $ forever $ do me <- try $ readChan logC >>= handle diff --git a/src/Discord/Handle.hs b/src/Discord/Handle.hs --- a/src/Discord/Handle.hs +++ b/src/Discord/Handle.hs @@ -1,3 +1,4 @@ +-- | The Discord Handle. Holds all the information related to the connection. module Discord.Handle ( DiscordHandle(..) , HandleThreadId(..) @@ -10,16 +11,28 @@ import Discord.Internal.Gateway (GatewayHandle(..), CacheHandle(..)) -- | Thread Ids marked by what type they are -data HandleThreadId = HandleThreadIdRest ThreadId - | HandleThreadIdCache ThreadId - | HandleThreadIdLogger ThreadId - | HandleThreadIdGateway ThreadId +data HandleThreadId + = -- | A Rest API thread + HandleThreadIdRest ThreadId + | -- | A cache thread + HandleThreadIdCache ThreadId + | -- | A logger thread + HandleThreadIdLogger ThreadId + | -- | A gateway thread + HandleThreadIdGateway ThreadId +-- | The main Handle structure data DiscordHandle = DiscordHandle - { discordHandleRestChan :: RestChanHandle - , discordHandleGateway :: GatewayHandle - , discordHandleCache :: CacheHandle - , discordHandleThreads :: [HandleThreadId] - , discordHandleLog :: Chan T.Text - , discordHandleLibraryError :: MVar T.Text + { -- | Handle to the Rest loop + discordHandleRestChan :: RestChanHandle + , -- | Handle to the Websocket gateway event loop + discordHandleGateway :: GatewayHandle + , -- | Handle to the cache + discordHandleCache :: CacheHandle + , -- | List of the threads currently in use by the library + discordHandleThreads :: [HandleThreadId] + , -- | `Chan` used to send messages to the internal logger + discordHandleLog :: Chan T.Text + , -- | `MVar` containing a description of the latest library error + discordHandleLibraryError :: MVar T.Text } diff --git a/src/Discord/Internal/Gateway.hs b/src/Discord/Internal/Gateway.hs --- a/src/Discord/Internal/Gateway.hs +++ b/src/Discord/Internal/Gateway.hs @@ -22,6 +22,7 @@ import Discord.Internal.Gateway.EventLoop (connectionLoop, GatewayHandle(..), GatewayException(..)) import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..)) +-- | Starts a thread for the cache startCacheThread :: Chan T.Text -> IO (CacheHandle, ThreadId) startCacheThread log = do events <- newChan :: IO (Chan (Either GatewayException EventInternalParse)) diff --git a/src/Discord/Internal/Gateway/EventLoop.hs b/src/Discord/Internal/Gateway/EventLoop.hs --- a/src/Discord/Internal/Gateway/EventLoop.hs +++ b/src/Discord/Internal/Gateway/EventLoop.hs @@ -27,28 +27,32 @@ import Discord.Internal.Rest.Prelude (apiVersion) +-- | Info the event processing loop needs to data GatewayHandle = GatewayHandle - { gatewayHandleEvents :: Chan (Either GatewayException EventInternalParse) - , gatewayHandleUserSendables :: Chan GatewaySendable - , gatewayHandleLastStatus :: IORef (Maybe UpdateStatusOpts) - , gatewayHandleLastSequenceId :: IORef Integer - , gatewayHandleSessionId :: IORef T.Text + { -- | Realtime events from discord + gatewayHandleEvents :: Chan (Either GatewayException EventInternalParse), + -- | Events the user sends to discord + gatewayHandleUserSendables :: Chan GatewaySendable, + -- | Recent set status (resent to discord on reconnect) + gatewayHandleLastStatus :: IORef (Maybe UpdateStatusOpts), + -- | Recent sent event sequence (used to reconnect) + gatewayHandleLastSequenceId :: IORef Integer, + -- | Which discord server session (used to reconnect) + gatewayHandleSessionId :: IORef T.Text } -data GatewayException = GatewayExceptionCouldNotConnect T.Text - | GatewayExceptionEventParseError T.Text T.Text - | GatewayExceptionUnexpected GatewayReceivable T.Text - | GatewayExceptionConnection ConnectionException T.Text +-- | Ways the gateway connection can fail with no possibility of recovery. +data GatewayException = GatewayExceptionIntent T.Text deriving (Show) - + -- | State of the eventloop data LoopState = LoopStart | LoopClosed | LoopReconnect deriving Show --- | Enough info for library to send info to discord. +-- | Info the sendableLoop reads when it writes to the websocket data SendablesData = SendablesData { sendableConnection :: Connection , librarySendables :: Chan GatewaySendableInternal @@ -56,104 +60,118 @@ , heartbeatInterval :: Integer } -{- -Some quick documentation for some of the variables passed around: -Auth needed to connect -GatewayIntent needed to connect -GatewayHandle (eventsGifts,status,usersends,seq,sesh) needed all over -log :: Chan (T.Text) needed all over - -sendableConnection set by setup, need sendableLoop -librarySendables :: Chan (GatewaySendableInternal) set by setup, need heartbeat -heartbeatInterval :: Int set by Hello, need heartbeat - -sequenceId :: Int id of last event received set by Resume, need heartbeat and reconnect -sessionId :: Text set by Ready, need reconnect --} - +-- | Gateway connection infinite loop. Get events from websocket and send them to the library user +-- +-- @ +-- Auth needed to connect +-- GatewayIntent needed to connect +-- GatewayHandle (eventsGives,status,usersends,seq,sesh) needed all over +-- log :: Chan (T.Text) needed all over +-- +-- sendableConnection set by setup, need sendableLoop +-- librarySendables :: Chan (GatewaySendableInternal) set by setup, need heartbeat +-- heartbeatInterval :: Int set by Hello, need heartbeat +-- +-- sequenceId :: Int id of last event received set by Resume, need heartbeat and reconnect +-- sessionId :: Text set by Ready, need reconnect +-- @ connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO () connectionLoop auth intent gatewayHandle log = outerloop LoopStart - where + where - outerloop :: LoopState -> IO () - outerloop state = do - mfirst <- firstmessage state - case mfirst of - Nothing -> pure () - Just first -> do - next <- try (startconnectionpls first) - case next :: Either SomeException LoopState of - Left _ -> do t <- getRandomR (3,20) - threadDelay (t * (10^(6 :: Int))) - writeChan log ("gateway - trying to reconnect after failure(s)") - outerloop LoopReconnect - Right n -> outerloop n + -- | Main connection loop. Catch exceptions and reconnect. + outerloop :: LoopState -> IO () + outerloop state = do + mfirst <- firstmessage state -- construct first message + case mfirst of + Nothing -> pure () -- close - firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal) - firstmessage state = - case state of - LoopStart -> pure $ Just $ Identify auth intent (0, 1) - LoopReconnect -> do seqId <- readIORef (gatewayHandleLastSequenceId gatewayHandle) - seshId <- readIORef (gatewayHandleSessionId gatewayHandle) - if seshId == "" - then do writeChan log ("gateway - WARNING seshID was not set by READY?") - pure $ Just $ Identify auth intent (0, 1) - else pure $ Just $ Resume auth seshId seqId - LoopClosed -> pure Nothing + Just message -> do + nextstate <- try (startOneConnection message) -- connection + case nextstate :: Either SomeException LoopState of + Left _ -> do t <- getRandomR (3,20) + threadDelay (t * (10^(6 :: Int))) + writeChan log ("gateway - trying to reconnect after failure(s)") + outerloop LoopReconnect + Right n -> outerloop n - startconnectionpls :: GatewaySendableInternal -> IO LoopState - startconnectionpls first = runSecureClient "gateway.discord.gg" 443 ("/?v=" <> T.unpack apiVersion <>"&encoding=json") $ \conn -> do - msg <- getPayload conn log - case msg of - Right (Hello interval) -> do + -- | Construct the initial websocket message to send based on which state of the loop. + -- Fresh start is Identify and a reconnect is Resume + firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal) + firstmessage state = + case state of + LoopStart -> pure $ Just $ Identify auth intent (0, 1) + LoopReconnect -> do seqId <- readIORef (gatewayHandleLastSequenceId gatewayHandle) + seshId <- readIORef (gatewayHandleSessionId gatewayHandle) + if seshId == "" + then do writeChan log ("gateway - WARNING seshID was not set by READY?") + pure $ Just $ Identify auth intent (0, 1) + else pure $ Just $ Resume auth seshId seqId + LoopClosed -> pure Nothing - internal <- newChan :: IO (Chan GatewaySendableInternal) - us <- newIORef False - -- start event loop - let sending = SendablesData conn internal us interval - sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log - heart <- forkIO $ heartbeat sending (gatewayHandleLastSequenceId gatewayHandle) + startOneConnection :: GatewaySendableInternal -> IO LoopState + startOneConnection message = runSecureClient "gateway.discord.gg" 443 ("/?v=" <> T.unpack apiVersion <>"&encoding=json") $ \conn -> do + msg <- getPayload conn log + case msg of + Right (Hello interval) -> do + -- setup sendables data + internal <- newChan :: IO (Chan GatewaySendableInternal) + sendingUser <- newIORef False + let sending = SendablesData { sendableConnection = conn + , librarySendables = internal + , startsendingUsers = sendingUser + , heartbeatInterval = interval + } + -- start websocket sending loop + sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log + heart <- forkIO $ heartbeat sending (gatewayHandleLastSequenceId gatewayHandle) + writeChan internal message - writeChan internal first - finally (runEventLoop gatewayHandle sending log) - (killThread heart >> killThread sendsId) - _ -> do - writeChan log "gateway - WARNING could not connect. Expected hello" - sendClose conn ("expected hello" :: BL.ByteString) - void $ forever $ void (receiveData conn :: IO BL.ByteString) - -- > after sendClose you should call receiveDataMessage until - -- > it throws an exception - -- haskell websockets documentation - threadDelay (3 * (10^(6 :: Int))) - pure LoopStart + -- run connection eventloop + finally (runEventLoop gatewayHandle sending log) + (killThread heart >> killThread sendsId) + _ -> do + writeChan log "gateway - WARNING could not connect. Expected hello" + sendClose conn ("expected hello" :: BL.ByteString) + void $ forever $ void (receiveData conn :: IO BL.ByteString) + -- > after sendClose you should call receiveDataMessage until + -- > it throws an exception + -- haskell websockets documentation + threadDelay (3 * (10^(6 :: Int))) + pure LoopStart + +-- | Process events from discord and write them to the onDiscordEvent Channel runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState runEventLoop thehandle sendablesData log = do loop where + eventChan :: Chan (Either GatewayException EventInternalParse) eventChan = gatewayHandleEvents thehandle + -- | Keep receiving Dispatch events until a reconnect or a restart loop = do eitherPayload <- getPayloadTimeout sendablesData log case eitherPayload :: Either ConnectionException GatewayReceivable of - Right (Hello _interval) -> do writeChan log ("eventloop - unexpected hello") - loop - Right (Dispatch event sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq - writeChan eventChan (Right event) + + Right (Dispatch event sq) -> do -- GOT AN EVENT: + writeIORef (gatewayHandleLastSequenceId thehandle) sq + writeChan eventChan (Right event) -- send the event to user case event of (InternalReady _ _ _ _ seshID _ _) -> writeIORef (gatewayHandleSessionId thehandle) seshID _ -> writeIORef (startsendingUsers sendablesData) True loop + Right (Hello _interval) -> do writeChan log ("eventloop - unexpected hello") + loop Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq writeChan (librarySendables sendablesData) (Heartbeat sq) loop - Right (Reconnect) -> pure LoopReconnect Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart + Right (Reconnect) -> pure LoopReconnect Right (HeartbeatAck) -> loop - Right (ParseError _e) -> -- getPayload logs the parse error. nothing to do here - loop + Right (ParseError _e) -> loop -- getPayload logs the parse error. nothing to do here Left (CloseRequest code str) -> case code of -- see Discord and MDN documentation on gateway close event codes @@ -164,26 +182,19 @@ 4000 -> pure LoopReconnect 4006 -> pure LoopStart 4007 -> pure LoopStart - 4014 -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello 0) $ + 4014 -> do writeChan eventChan (Left (GatewayExceptionIntent $ "Tried to declare an unauthorized GatewayIntent. " <> "Use the discord app manager to authorize by following: " <> - "https://github.com/aquarial/discord-haskell/blob/master/docs/intents.md")) + "https://github.com/discord-haskell/discord-haskell/blob/master/docs/intents.md")) pure LoopClosed _ -> do writeChan log ("gateway - unknown websocket close code " <> T.pack (show code) <> " [" <> TE.decodeUtf8 (BL.toStrict str) <> "]. Consider opening an issue " - <> "https://github.com/aquarial/discord-haskell/issues") + <> "https://github.com/discord-haskell/discord-haskell/issues") pure LoopStart Left _ -> pure LoopReconnect -heartbeat :: SendablesData -> IORef Integer -> IO () -heartbeat sendablesData seqKey = do - threadDelay (3 * 10^(6 :: Int)) - forever $ do - num <- readIORef seqKey - writeChan (librarySendables sendablesData) (Heartbeat num) - threadDelay (fromInteger (heartbeatInterval sendablesData * 1000)) - +-- | Blocking wait for next payload from the websocket (returns "Reconnect" after 1.5*heartbeatInterval seconds) getPayloadTimeout :: SendablesData -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) getPayloadTimeout sendablesData log = do let interval = heartbeatInterval sendablesData @@ -193,6 +204,7 @@ Left () -> pure (Right Reconnect) Right other -> pure other +-- | Blocking wait for next payload from the websocket getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) getPayload conn log = try $ do msg' <- receiveData conn @@ -202,30 +214,38 @@ <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg')) pure (ParseError (T.pack err)) +-- | Infinite loop to send heartbeats to the chan +heartbeat :: SendablesData -> IORef Integer -> IO () +heartbeat sendablesData seqKey = do + threadDelay (3 * 10^(6 :: Int)) + forever $ do + num <- readIORef seqKey + writeChan (librarySendables sendablesData) (Heartbeat num) + threadDelay (fromInteger (heartbeatInterval sendablesData * 1000)) --- simple idea: send payloads from user/sys to connection --- has to be complicated though + +-- | Infinite loop to send library/user events to discord with the actual websocket connection sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO () -sendableLoop conn ghandle sendablesData _log = sendSysLoop +sendableLoop conn ghandle sendablesData _log = sendLoop where - sendSysLoop = do - threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) - payload <- readChan (librarySendables sendablesData) - sendTextData conn (encode payload) - -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (encode payload))) - usersending <- readIORef (startsendingUsers sendablesData) - if not usersending - then sendSysLoop - else do act <- readIORef (gatewayHandleLastStatus ghandle) - case act of Nothing -> pure () - Just opts -> sendTextData conn (encode (UpdateStatus opts)) - sendUserLoop - - sendUserLoop = do + sendLoop = do -- send a ~120 events a min by delaying threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) -- payload :: Either GatewaySendableInternal GatewaySendable - payload <- race (readChan (gatewayHandleUserSendables ghandle)) (readChan (librarySendables sendablesData)) - sendTextData conn (either encode encode payload) + payload <- race nextLibrary nextUser -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload))) - sendUserLoop + sendTextData conn (either encode encode payload) + sendLoop + + -- | next event sent by library + nextLibrary :: IO GatewaySendableInternal + nextLibrary = readChan (librarySendables sendablesData) + + -- | next event sent by user (once startsendingUsers is set) + nextUser :: IO GatewaySendable + nextUser = do usersending <- readIORef (startsendingUsers sendablesData) + if usersending + then readChan (gatewayHandleUserSendables ghandle) + else threadDelay (4 * (10^(6::Int))) >> nextUser + + diff --git a/src/Discord/Internal/Rest.hs b/src/Discord/Internal/Rest.hs --- a/src/Discord/Internal/Rest.hs +++ b/src/Discord/Internal/Rest.hs @@ -25,6 +25,7 @@ import Discord.Internal.Types import Discord.Internal.Rest.HTTP +-- | Handle to the Rest 'Chan' data RestChanHandle = RestChanHandle { restHandleChan :: Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) } diff --git a/src/Discord/Internal/Rest/ApplicationCommands.hs b/src/Discord/Internal/Rest/ApplicationCommands.hs --- a/src/Discord/Internal/Rest/ApplicationCommands.hs +++ b/src/Discord/Internal/Rest/ApplicationCommands.hs @@ -20,29 +20,102 @@ jsonRequest = applicationCommandJsonRequest majorRoute = applicationCommandMajorRoute +-- | Requests related to application commands data ApplicationCommandRequest a where - GetGlobalApplicationCommands :: ApplicationId -> ApplicationCommandRequest [ApplicationCommand] - CreateGlobalApplicationCommand :: ApplicationId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand - GetGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand - EditGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> EditApplicationCommand -> ApplicationCommandRequest ApplicationCommand - DeleteGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest () - BulkOverWriteGlobalApplicationCommand :: ApplicationId -> [CreateApplicationCommand] -> ApplicationCommandRequest () - GetGuildApplicationCommands :: ApplicationId -> GuildId -> ApplicationCommandRequest [ApplicationCommand] - CreateGuildApplicationCommand :: ApplicationId -> GuildId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand - GetGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand - EditGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand - DeleteGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest () - BulkOverWriteGuildApplicationCommand :: ApplicationId -> GuildId -> [CreateApplicationCommand] -> ApplicationCommandRequest () - GetGuildApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandRequest GuildApplicationCommandPermissions - GetApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest GuildApplicationCommandPermissions - EditApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandId -> [ApplicationCommandPermissions] -> ApplicationCommandRequest GuildApplicationCommandPermissions - -- | The only parameters needed in the GuildApplicationCommandPermissions - -- objects are id and permissions. - BatchEditApplicationCommandPermissions :: ApplicationId -> GuildId -> [GuildApplicationCommandPermissions] -> ApplicationCommandRequest [GuildApplicationCommandPermissions] + -- | Fetch all of the global commands for your application. Returns an list of 'ApplicationCommand's. + GetGlobalApplicationCommands :: ApplicationId + -> ApplicationCommandRequest [ApplicationCommand] + -- | Create a new global command. Returns an 'ApplicationCommand'. + -- + -- __Note__: Creating a command with the same name as an existing command for your application will overwrite the old command. + CreateGlobalApplicationCommand :: ApplicationId + -> CreateApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Fetch a global command for your application. Returns an 'ApplicationCommand'. + GetGlobalApplicationCommand :: ApplicationId + -> ApplicationCommandId + -> ApplicationCommandRequest ApplicationCommand + -- | Edit a global command. Returns an 'ApplicationCommand'. + -- + -- All fields are optional, but any fields provided will entirely overwrite the existing values of those fields. + EditGlobalApplicationCommand :: ApplicationId + -> ApplicationCommandId + -> EditApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Delete a global command. + DeleteGlobalApplicationCommand :: ApplicationId + -> ApplicationCommandId + -> ApplicationCommandRequest () + -- | Takes a list of 'CreateApplicationCommand', overwriting the existing global command list for this application. + -- + -- __Note__: This will overwrite __all__ types of application commands: slash commands, user commands, and message commands. + BulkOverWriteGlobalApplicationCommand :: ApplicationId + -> [CreateApplicationCommand] + -> ApplicationCommandRequest () + -- | Fetch all of the guild commands for your application for a specific guild. Returns an list of 'ApplicationCommands'. + GetGuildApplicationCommands :: ApplicationId + -> GuildId + -> ApplicationCommandRequest [ApplicationCommand] + -- | Create a new guild command. New guild commands will be available in the guild immediately. + -- Returns an 'ApplicationCommand'. + -- If the command did not already exist, it will count toward daily application command create limits. + -- + -- __Note__: Creating a command with the same name as an existing command for your application will overwrite the old command. + CreateGuildApplicationCommand :: ApplicationId + -> GuildId + -> CreateApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Fetch a guild command for your application. Returns an 'ApplicationCommand' + GetGuildApplicationCommand :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> ApplicationCommandRequest ApplicationCommand + -- | Edit a guild command. Updates for guild commands will be available immediately. Returns an 'ApplicationCommand'. + -- All fields are optional, but any fields provided will entirely overwrite the existing values of those fields. + EditGuildApplicationCommand :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> CreateApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Delete a guild command. + DeleteGuildApplicationCommand :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> ApplicationCommandRequest () + -- | Takes a list of `CreateApplicationCommand`, overwriting the existing command list for this application for the targeted guild. + -- + -- __Note__: This will overwrite __all__ types of application commands: slash commands, user commands, and message commands. + BulkOverWriteGuildApplicationCommand :: ApplicationId + -> GuildId + -> [CreateApplicationCommand] + -> ApplicationCommandRequest () + -- | Fetches permissions for all commands for your application in a guild. + GetGuildApplicationCommandPermissions :: ApplicationId + -> GuildId + -> ApplicationCommandRequest GuildApplicationCommandPermissions + -- | Fetches permissions for a specific command for your application in a guild. + GetApplicationCommandPermissions :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> ApplicationCommandRequest GuildApplicationCommandPermissions + -- | Edits command permissions for a specific command for your application. + -- You can add up to 100 permission overwrites for a command. + -- __Notes__: + -- + -- * This endpoint will overwrite existing permissions for the command in that guild + -- * This endpoint requires authentication with a Bearer token that has permission to manage the guild and its roles. + -- * Deleting or renaming a command will permanently delete all permissions for the command + EditApplicationCommandPermissions :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> [ApplicationCommandPermissions] + -> ApplicationCommandRequest GuildApplicationCommandPermissions +-- | The base url for application commands applications :: ApplicationId -> R.Url 'R.Https -applications s = baseUrl /: "applications" // s +applications s = baseUrl /: "applications" /~ s +-- | The major routes identifiers for `ApplicationCommandRequest`s applicationCommandMajorRoute :: ApplicationCommandRequest a -> String applicationCommandMajorRoute a = case a of (GetGlobalApplicationCommands aid) -> "get_glob_appcomm" <> show aid @@ -60,8 +133,8 @@ (GetGuildApplicationCommandPermissions aid _) -> "appcom_perm " <> show aid (GetApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid (EditApplicationCommandPermissions aid _ _ _) -> "appcom_perm " <> show aid - (BatchEditApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid +-- | The `JsonRequest`s for `ApplicationCommandRequest`s applicationCommandJsonRequest :: ApplicationCommandRequest a -> JsonRequest applicationCommandJsonRequest a = case a of (GetGlobalApplicationCommands aid) -> @@ -69,33 +142,31 @@ (CreateGlobalApplicationCommand aid cac) -> Post (applications aid /: "commands") (convert cac) mempty (GetGlobalApplicationCommand aid aci) -> - Get (applications aid /: "commands" // aci) mempty + Get (applications aid /: "commands" /~ aci) mempty (EditGlobalApplicationCommand aid aci eac) -> - Patch (applications aid /: "commands" // aci) (convert eac) mempty + Patch (applications aid /: "commands" /~ aci) (convert eac) mempty (DeleteGlobalApplicationCommand aid aci) -> - Delete (applications aid /: "commands" // aci) mempty + Delete (applications aid /: "commands" /~ aci) mempty (BulkOverWriteGlobalApplicationCommand aid cacs) -> Put (applications aid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty (GetGuildApplicationCommands aid gid) -> - Get (applications aid /: "guilds" // gid /: "commands") mempty + Get (applications aid /: "guilds" /~ gid /: "commands") mempty (CreateGuildApplicationCommand aid gid cac) -> - Post (applications aid /: "guilds" // gid /: "commands") (convert cac) mempty + Post (applications aid /: "guilds" /~ gid /: "commands") (convert cac) mempty (GetGuildApplicationCommand aid gid aci) -> - Get (applications aid /: "guilds" // gid /: "commands" // aci) mempty + Get (applications aid /: "guilds" /~ gid /: "commands" /~ aci) mempty (EditGuildApplicationCommand aid gid aci eac) -> - Patch (applications aid /: "guilds" // gid /: "commands" // aci) (convert eac) mempty + Patch (applications aid /: "guilds" /~ gid /: "commands" /~ aci) (convert eac) mempty (DeleteGuildApplicationCommand aid gid aci) -> - Delete (applications aid /: "guilds" // gid /: "commands" // aci) mempty + Delete (applications aid /: "guilds" /~ gid /: "commands" /~ aci) mempty (BulkOverWriteGuildApplicationCommand aid gid cacs) -> - Put (applications aid /: "guilds" // gid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty + Put (applications aid /: "guilds" /~ gid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty (GetGuildApplicationCommandPermissions aid gid) -> - Get (applications aid /: "guilds" // gid /: "commands" /: "permissions") mempty + Get (applications aid /: "guilds" /~ gid /: "commands" /: "permissions") mempty (GetApplicationCommandPermissions aid gid cid) -> - Get (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") mempty + Get (applications aid /: "guilds" /~ gid /: "commands" /~ cid /: "permissions") mempty (EditApplicationCommandPermissions aid gid cid ps) -> - Put (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") (R.ReqBodyJson $ toJSON (GuildApplicationCommandPermissions cid aid gid ps)) mempty - (BatchEditApplicationCommandPermissions aid gid ps) -> - Put (applications aid /: "guilds" // gid /: "commands" /: "permissions") (R.ReqBodyJson $ toJSON ps) mempty + Put (applications aid /: "guilds" /~ gid /: "commands" /~ cid /: "permissions") (R.ReqBodyJson $ toJSON (GuildApplicationCommandPermissions cid aid gid ps)) mempty where convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) convert = (pure @RestIO) . R.ReqBodyJson . toJSON diff --git a/src/Discord/Internal/Rest/Channel.hs b/src/Discord/Internal/Rest/Channel.hs --- a/src/Discord/Internal/Rest/Channel.hs +++ b/src/Discord/Internal/Rest/Channel.hs @@ -15,7 +15,6 @@ , ModifyChannelOpts(..) , ChannelPermissionsOpts(..) , GroupDMAddRecipientOpts(..) - , ChannelPermissionsOptsType(..) , StartThreadOpts(..) , StartThreadNoMessageOpts(..) , ListThreads(..) @@ -30,7 +29,7 @@ import qualified Data.ByteString.Lazy as BL import Network.HTTP.Client (RequestBody (RequestBodyBS)) import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS) -import Network.HTTP.Req ((/:)) +import Network.HTTP.Req ((/:), (/~)) import qualified Network.HTTP.Req as R import Discord.Internal.Rest.Prelude @@ -77,13 +76,13 @@ -- | Deletes a group of messages. BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () -- | Edits a permission overrides for a channel. - EditChannelPermissions :: ChannelId -> OverwriteId -> ChannelPermissionsOpts -> ChannelRequest () + EditChannelPermissions :: ChannelId -> Either RoleId UserId -> ChannelPermissionsOpts -> ChannelRequest () -- | Gets all instant invites to a channel. GetChannelInvites :: ChannelId -> ChannelRequest Object -- | Creates an instant invite to a channel. CreateChannelInvite :: ChannelId -> ChannelInviteOpts -> ChannelRequest Invite -- | Deletes a permission override from a channel. - DeleteChannelPermission :: ChannelId -> OverwriteId -> ChannelRequest () + DeleteChannelPermission :: ChannelId -> Either RoleId UserId -> ChannelRequest () -- | Sends a typing indicator a channel which lasts 10 seconds. TriggerTypingIndicator :: ChannelId -> ChannelRequest () -- | Gets all pinned messages of a channel. @@ -129,16 +128,24 @@ ListJoinedPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads --- | Data constructor for CreateMessageDetailed requests. +-- | Options for `CreateMessageDetailed` requests. data MessageDetailedOpts = MessageDetailedOpts - { messageDetailedContent :: T.Text - , messageDetailedTTS :: Bool - , messageDetailedEmbeds :: Maybe [CreateEmbed] - , messageDetailedFile :: Maybe (T.Text, B.ByteString) - , messageDetailedAllowedMentions :: Maybe AllowedMentions - , messageDetailedReference :: Maybe MessageReference - , messageDetailedComponents :: Maybe [ActionRow] - , messageDetailedStickerIds :: Maybe [StickerId] + { -- | The message contents (up to 2000 characters) + messageDetailedContent :: T.Text + , -- | `True` if this is a TTS message + messageDetailedTTS :: Bool + , -- | embedded rich content (up to 6000 characters) + messageDetailedEmbeds :: Maybe [CreateEmbed] + , -- | the contents of the file being sent + messageDetailedFile :: Maybe (T.Text, B.ByteString) + , -- | allowed mentions for the message + messageDetailedAllowedMentions :: Maybe AllowedMentions + , -- | If `Just`, reply to the message referenced + messageDetailedReference :: Maybe MessageReference + , -- | Message components for the message + messageDetailedComponents :: Maybe [ActionRow] + , -- | IDs of up to 3 `Sticker` in the server to send with the message + messageDetailedStickerIds :: Maybe [StickerId] } deriving (Show, Read, Eq, Ord) instance Default MessageDetailedOpts where @@ -152,7 +159,7 @@ , messageDetailedStickerIds = Nothing } --- | Data constructor for GetReaction requests +-- | Data constructor for `GetReactions` requests data ReactionTiming = BeforeReaction MessageId | AfterReaction MessageId | LatestReaction @@ -164,7 +171,9 @@ (AfterReaction snow) -> "after" R.=: show snow (LatestReaction) -> mempty --- | Data constructor for GetChannelMessages requests. See +-- | Data constructor for `GetChannelMessages` requests. +-- +-- See data MessageTiming = AroundMessage MessageId | BeforeMessage MessageId | AfterMessage MessageId @@ -178,11 +187,17 @@ (AfterMessage snow) -> "after" R.=: show snow (LatestMessages) -> mempty +-- | Options for `CreateChannelInvite` requests data ChannelInviteOpts = ChannelInviteOpts - { channelInviteOptsMaxAgeSeconds :: Maybe Integer - , channelInviteOptsMaxUsages :: Maybe Integer - , channelInviteOptsIsTemporary :: Maybe Bool - , channelInviteOptsDontReuseSimilarInvite :: Maybe Bool + { -- | How long the invite is valid for (in seconds) + channelInviteOptsMaxAgeSeconds :: Maybe Integer + , -- | How many uses the invite is valid for + channelInviteOptsMaxUsages :: Maybe Integer + , -- | Whether this invite only grants temporary membership + channelInviteOptsIsTemporary :: Maybe Bool + , -- | Don't reuse a similar invite. Useful for creating many unique one time + -- use invites + channelInviteOptsDontReuseSimilarInvite :: Maybe Bool } deriving (Show, Read, Eq, Ord) instance ToJSON ChannelInviteOpts where @@ -192,24 +207,46 @@ ("temporary", toJSON <$> channelInviteOptsIsTemporary), ("unique", toJSON <$> channelInviteOptsDontReuseSimilarInvite) ] ] +-- | Options for `ModifyChannel` requests data ModifyChannelOpts = ModifyChannelOpts - { modifyChannelName :: Maybe T.Text - , modifyChannelPosition :: Maybe Integer - , modifyChannelTopic :: Maybe T.Text - , modifyChannelNSFW :: Maybe Bool - , modifyChannelBitrate :: Maybe Integer - , modifyChannelUserRateLimit :: Maybe Integer - , modifyChannelPermissionOverwrites :: Maybe [Overwrite] - , modifyChannelParentId :: Maybe ChannelId - , modifyChannelDefaultAutoArchive :: Maybe Integer - , modifyChannelThreadArchived :: Maybe Bool - , modifyChannelThreadAutoArchive :: Maybe Integer - , modifyChannelThreadLocked :: Maybe Bool - , modifyChannelThreadInvitiable :: Maybe Bool + { -- | (All) The name of the channel (max 100 characters) + modifyChannelName :: Maybe T.Text + , -- | (All) Position of the channel in the listing + modifyChannelPosition :: Maybe Integer + , -- | (Text) The channel topic text (max 1024 characters) + modifyChannelTopic :: Maybe T.Text + , -- | (Text) Wether the channel is tagged as NSFW + modifyChannelNSFW :: Maybe Bool + , -- | (Voice) Bitrate (in bps) of a voice channel. Min 8000, max 96000 + -- (128000 for boosted servers) + modifyChannelBitrate :: Maybe Integer + , -- | (Text) The rate limit of the channel, in seconds (0-21600), does not + -- affect bots and users with @manage_channel@ or @manage_messages@ + -- permissons + modifyChannelUserRateLimit :: Maybe Integer + , -- | (Voice) the user limit of the voice channel, max 99 + modifyChannelUserLimit :: Maybe Integer + , -- | (All) The channel permissions + modifyChannelPermissionOverwrites :: Maybe [Overwrite] + , -- | (All) The parent category of the channel + modifyChannelParentId :: Maybe ChannelId + , -- | (Text) Auto-archive duration for Threads + modifyChannelDefaultAutoArchive :: Maybe Integer + , -- | (Thread) Whether the thread is archived + modifyChannelThreadArchived :: Maybe Bool + , -- | (Thread) duration in minutes to automatically archive the thread after + -- recent activity, can be set to: 60, 1440, 4320 or 10080 + modifyChannelThreadAutoArchive :: Maybe Integer + , -- | (Thread) Whether the thread is locked. When a thread is locked, only + -- users with @manage_threads@ can unarchive it + modifyChannelThreadLocked :: Maybe Bool + , -- | (Thread) Whether non-moderators can add other non-moderators to a + -- thread. Only available on private threads + modifyChannelThreadInvitable :: Maybe Bool } deriving (Show, Read, Eq, Ord) instance Default ModifyChannelOpts where - def = ModifyChannelOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + def = ModifyChannelOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing instance ToJSON ModifyChannelOpts where toJSON ModifyChannelOpts{..} = object [(name, val) | (name, Just val) <- @@ -218,45 +255,53 @@ ("topic", toJSON <$> modifyChannelTopic), ("nsfw", toJSON <$> modifyChannelNSFW), ("bitrate", toJSON <$> modifyChannelBitrate), - ("user_limit", toJSON <$> modifyChannelUserRateLimit), + ("rate_limit_per_user", toJSON <$> modifyChannelUserRateLimit), + ("user_limit", toJSON <$> modifyChannelUserLimit), ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites), ("parent_id", toJSON <$> modifyChannelParentId), ("default_auto_archive_duration", toJSON <$> modifyChannelDefaultAutoArchive), ("archived", toJSON <$> modifyChannelThreadArchived), ("auto_archive_duration", toJSON <$> modifyChannelThreadAutoArchive), ("locked", toJSON <$> modifyChannelThreadLocked), - ("invitable", toJSON <$> modifyChannelThreadInvitiable) ] ] + ("invitable", toJSON <$> modifyChannelThreadInvitable) ] ] +-- | Options for The `EditChannelPermissions` request +-- +-- Since the JSON encoding of this datatype will require information in the +-- route (the Either decides whether the overwrite is for a user or a role), we +-- do not provide a ToJSON instance. Instead, the JSON is manually constructed +-- in the 'channelJsonRequest' function. data ChannelPermissionsOpts = ChannelPermissionsOpts - { channelPermissionsOptsAllow :: Integer - , channelPermissionsOptsDeny :: Integer - , channelPermissionsOptsType :: ChannelPermissionsOptsType + { -- | The permission integer for the explicitly allowed permissions + channelPermissionsOptsAllow :: Integer + , -- | The permission integer for the explicitly denied permissions + channelPermissionsOptsDeny :: Integer } deriving (Show, Read, Eq, Ord) -data ChannelPermissionsOptsType = ChannelPermissionsOptsUser - | ChannelPermissionsOptsRole - deriving (Show, Read, Eq, Ord) - -instance ToJSON ChannelPermissionsOptsType where - toJSON t = case t of ChannelPermissionsOptsUser -> String "member" - ChannelPermissionsOptsRole -> String "role" - -instance ToJSON ChannelPermissionsOpts where - toJSON (ChannelPermissionsOpts a d t) = object [ ("allow", toJSON a ) - , ("deny", toJSON d) - , ("type", toJSON t)] - --- | https://discord.com/developers/docs/resources/channel#group-dm-add-recipient +-- | Options for `GroupDMAddRecipient` request +-- +-- See data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts - { groupDMAddRecipientUserToAdd :: UserId - , groupDMAddRecipientUserToAddNickName :: T.Text - , groupDMAddRecipientGDMJoinAccessToken :: T.Text + { -- | The id of the user to add to the Group DM + groupDMAddRecipientUserToAdd :: UserId + , -- | The nickname given to the user being added + groupDMAddRecipientUserToAddNickName :: T.Text + , -- | Access token of the user. That user must have granted your app the + -- @gdm.join@ scope. + groupDMAddRecipientGDMJoinAccessToken :: T.Text } deriving (Show, Read, Eq, Ord) +-- | Options for `StartThreadFromMessage` request data StartThreadOpts = StartThreadOpts - { startThreadName :: T.Text - , startThreadAutoArchive :: Maybe Integer -- ^ can be one of 60, 1440, 4320, 10080 - , startThreadRateLimit :: Maybe Integer + { -- | Name of the thread + startThreadName :: T.Text + , -- | Period of innactivity after which the thread gets archived in minutes. + -- + -- Can be one of 60, 1440, 4320, 10080 + startThreadAutoArchive :: Maybe Integer + , -- | Amount of seconds a user has to wait before sending another message + -- (0-21600) + startThreadRateLimit :: Maybe Integer } deriving (Show, Read, Eq, Ord) instance ToJSON StartThreadOpts where @@ -267,10 +312,18 @@ ] ] +-- | Options for `StartThreadNoMessage` request data StartThreadNoMessageOpts = StartThreadNoMessageOpts - { startThreadNoMessageBaseOpts :: StartThreadOpts - , startThreadNoMessageType :: Integer -- ^ 10, 11, or 12 (https://discord.com/developers/docs/resources/channel#channel-object-channel-types) - , startThreadNoMessageInvitable :: Maybe Bool + { -- | Base options for the thread + startThreadNoMessageBaseOpts :: StartThreadOpts + , -- | The type of thread to create + -- + -- Can be @10@, @11@, or @12@. See + -- + startThreadNoMessageType :: Integer + , -- | Whether non-moderators can add other non-moderators to a thread. Only + -- available when creating a private thread. + startThreadNoMessageInvitable :: Maybe Bool } deriving (Show, Read, Eq, Ord) instance ToJSON StartThreadNoMessageOpts where @@ -283,10 +336,16 @@ ] ] +-- | Result type of `ListJoinedPrivateArchivedThreads`, +-- `ListPrivateArchivedThreads` and `ListPublicArchivedThreads` data ListThreads = ListThreads - { listThreadsThreads :: [Channel] - , listThreadsMembers :: [ThreadMember] - , listThreadsHasMore :: Bool -- ^ whether there is more data to retrieve + { -- | The returned threads + listThreadsThreads :: [Channel] + , -- | A thread member object for each returned thread the current user has + -- joined + listThreadsMembers :: [ThreadMember] + , -- | Whether there is more data to retrieve + listThreadsHasMore :: Bool } deriving (Show, Read, Eq, Ord) instance ToJSON ListThreads where @@ -357,26 +416,26 @@ channelJsonRequest :: ChannelRequest r -> JsonRequest channelJsonRequest c = case c of (GetChannel chan) -> - Get (channels // chan) mempty + Get (channels /~ chan) mempty (ModifyChannel chan patch) -> - Patch (channels // chan) (pure (R.ReqBodyJson patch)) mempty + Patch (channels /~ chan) (pure (R.ReqBodyJson patch)) mempty (DeleteChannel chan) -> - Delete (channels // chan) mempty + Delete (channels /~ chan) mempty (GetChannelMessages chan (n,timing)) -> let n' = max 1 (min 100 n) options = "limit" R.=: n' <> messageTimingToQuery timing - in Get (channels // chan /: "messages") options + in Get (channels /~ chan /: "messages") options (GetChannelMessage (chan, msg)) -> - Get (channels // chan /: "messages" // msg) mempty + Get (channels /~ chan /: "messages" /~ msg) mempty (CreateMessage chan msg) -> let content = ["content" .= msg] body = pure $ R.ReqBodyJson $ object content - in Post (channels // chan /: "messages") body mempty + in Post (channels /~ chan /: "messages") body mempty (CreateMessageDetailed chan msgOpts) -> let fileUpload = messageDetailedFile msgOpts @@ -404,33 +463,33 @@ payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData body = R.reqBodyMultipart (payloadPart : filePart) - in Post (channels // chan /: "messages") body mempty + in Post (channels /~ chan /: "messages") body mempty (CreateReaction (chan, msgid) emoji) -> let e = cleanupEmoji emoji - in Put (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me" ) + in Put (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e /: "@me" ) R.NoReqBody mempty (DeleteOwnReaction (chan, msgid) emoji) -> let e = cleanupEmoji emoji - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me" ) mempty + in Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e /: "@me" ) mempty (DeleteUserReaction (chan, msgid) uID emoji) -> let e = cleanupEmoji emoji - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e // uID ) mempty + in Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e /~ uID ) mempty (DeleteSingleReaction (chan, msgid) emoji) -> let e = cleanupEmoji emoji - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e) mempty + in Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e) mempty (GetReactions (chan, msgid) emoji (n, timing)) -> let e = cleanupEmoji emoji n' = max 1 (min 100 n) options = "limit" R.=: n' <> reactionTimingToQuery timing - in Get (channels // chan /: "messages" // msgid /: "reactions" /: e) options + in Get (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e) options (DeleteAllReactions (chan, msgid)) -> - Delete (channels // chan /: "messages" // msgid /: "reactions" ) mempty + Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" ) mempty -- copied from CreateMessageDetailed, should be outsourced to function probably (EditMessage (chan, msg) msgOpts) -> @@ -459,90 +518,93 @@ payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData body = R.reqBodyMultipart (payloadPart : filePart) - in Patch (channels // chan /: "messages" // msg) body mempty + in Patch (channels /~ chan /: "messages" /~ msg) body mempty (DeleteMessage (chan, msg)) -> - Delete (channels // chan /: "messages" // msg) mempty + Delete (channels /~ chan /: "messages" /~ msg) mempty (BulkDeleteMessage (chan, msgs)) -> let body = pure . R.ReqBodyJson $ object ["messages" .= msgs] - in Post (channels // chan /: "messages" /: "bulk-delete") body mempty + in Post (channels /~ chan /: "messages" /: "bulk-delete") body mempty - (EditChannelPermissions chan perm patch) -> - Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty + (EditChannelPermissions chan overwriteId (ChannelPermissionsOpts a d)) -> + let body = R.ReqBodyJson $ object [("type", toJSON $ (either (const 0) (const 1) overwriteId :: Int)) + ,("allow", toJSON a) + ,("deny", toJSON d)] + in Put (channels /~ chan /: "permissions" /~ either unId unId overwriteId) body mempty (GetChannelInvites chan) -> - Get (channels // chan /: "invites") mempty + Get (channels /~ chan /: "invites") mempty (CreateChannelInvite chan patch) -> - Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty + Post (channels /~ chan /: "invites") (pure (R.ReqBodyJson patch)) mempty - (DeleteChannelPermission chan perm) -> - Delete (channels // chan /: "permissions" // perm) mempty + (DeleteChannelPermission chan overwriteId) -> + Delete (channels /~ chan /: "permissions" /~ either unId unId overwriteId) mempty (TriggerTypingIndicator chan) -> - Post (channels // chan /: "typing") (pure R.NoReqBody) mempty + Post (channels /~ chan /: "typing") (pure R.NoReqBody) mempty (GetPinnedMessages chan) -> - Get (channels // chan /: "pins") mempty + Get (channels /~ chan /: "pins") mempty (AddPinnedMessage (chan, msg)) -> - Put (channels // chan /: "pins" // msg) R.NoReqBody mempty + Put (channels /~ chan /: "pins" /~ msg) R.NoReqBody mempty (DeletePinnedMessage (chan, msg)) -> - Delete (channels // chan /: "pins" // msg) mempty + Delete (channels /~ chan /: "pins" /~ msg) mempty (GroupDMAddRecipient chan (GroupDMAddRecipientOpts uid nick tok)) -> - Put (channels // chan // chan /: "recipients" // uid) + Put (channels /~ chan /~ chan /: "recipients" /~ uid) (R.ReqBodyJson (object [ ("access_token", toJSON tok) , ("nick", toJSON nick)])) mempty (GroupDMRemoveRecipient chan userid) -> - Delete (channels // chan // chan /: "recipients" // userid) mempty + Delete (channels /~ chan /~ chan /: "recipients" /~ userid) mempty (StartThreadFromMessage chan mid sto) -> - Post (channels // chan /: "messages" // mid /: "threads") + Post (channels /~ chan /: "messages" /~ mid /: "threads") (pure $ R.ReqBodyJson $ toJSON sto) mempty (StartThreadNoMessage chan sto) -> - Post (channels // chan /: "messages" /: "threads") + Post (channels /~ chan /: "messages" /: "threads") (pure $ R.ReqBodyJson $ toJSON sto) mempty (JoinThread chan) -> - Put (channels // chan /: "thread-members" /: "@me") + Put (channels /~ chan /: "thread-members" /: "@me") R.NoReqBody mempty (AddThreadMember chan uid) -> - Put (channels // chan /: "thread-members" // uid) + Put (channels /~ chan /: "thread-members" /~ uid) R.NoReqBody mempty (LeaveThread chan) -> - Delete (channels // chan /: "thread-members" /: "@me") + Delete (channels /~ chan /: "thread-members" /: "@me") mempty (RemoveThreadMember chan uid) -> - Delete (channels // chan /: "thread-members" // uid) + Delete (channels /~ chan /: "thread-members" /~ uid) mempty (GetThreadMember chan uid) -> - Get (channels // chan /: "thread-members" // uid) + Get (channels /~ chan /: "thread-members" /~ uid) mempty (ListThreadMembers chan) -> - Get (channels // chan /: "thread-members") + Get (channels /~ chan /: "thread-members") mempty (ListPublicArchivedThreads chan (time, lim)) -> - Get (channels // chan /: "threads" /: "archived" /: "public") + Get (channels /~ chan /: "threads" /: "archived" /: "public") (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) (ListPrivateArchivedThreads chan (time, lim)) -> - Get (channels // chan /: "threads" /: "archived" /: "private") + Get (channels /~ chan /: "threads" /: "archived" /: "private") (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) (ListJoinedPrivateArchivedThreads chan (time, lim)) -> - Get (channels // chan /: "users" /: "@me" /: "threads" /: "archived" /: "private") + Get (channels /~ chan /: "users" /: "@me" /: "threads" /: "archived" /: "private") (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) diff --git a/src/Discord/Internal/Rest/Emoji.hs b/src/Discord/Internal/Rest/Emoji.hs --- a/src/Discord/Internal/Rest/Emoji.hs +++ b/src/Discord/Internal/Rest/Emoji.hs @@ -9,13 +9,13 @@ ( EmojiRequest (..), ModifyGuildEmojiOpts (..), parseEmojiImage, + parseStickerImage, StickerRequest (..), CreateGuildStickerOpts (..), EditGuildStickerOpts (..) ) where -import Codec.Picture import Data.Aeson import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 @@ -23,7 +23,7 @@ import qualified Data.Text.Encoding as TE import Discord.Internal.Rest.Prelude import Discord.Internal.Types -import Network.HTTP.Req ((/:)) +import Network.HTTP.Req ((/:), (/~)) import qualified Network.HTTP.Req as R instance Request (EmojiRequest a) where @@ -37,7 +37,7 @@ -- | Emoji object for the given guild and emoji ID GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission. - CreateGuildEmoji :: GuildId -> T.Text -> EmojiImageParsed -> EmojiRequest Emoji + CreateGuildEmoji :: GuildId -> T.Text -> Base64Image Emoji -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission ModifyGuildEmoji :: GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission @@ -53,46 +53,20 @@ toJSON (ModifyGuildEmojiOpts name roles) = object ["name" .= name, "roles" .= roles] -newtype EmojiImageParsed = EmojiImageParsed T.Text - deriving (Show, Read, Eq, Ord) -parseEmojiImage :: B.ByteString -> Either T.Text EmojiImageParsed -parseEmojiImage bs = - if B.length bs > 256000 - then Left "Cannot create emoji - File is larger than 256kb" - else case (decodeGifImages bs, decodeImage bs) of - (Left e1, Left e2) -> - Left - ( "Could not parse image or gif: " <> T.pack e1 - <> " and " - <> T.pack e2 - ) - (Right ims, _) -> - if all is128 ims - then - Right - ( EmojiImageParsed - ( "data:text/plain;" - <> "base64," - <> TE.decodeUtf8 (B64.encode bs) - ) - ) - else Left "The frames are not all 128x128" - (_, Right im) -> - if is128 im - then - Right - ( EmojiImageParsed - ( "data:text/plain;" - <> "base64," - <> TE.decodeUtf8 (B64.encode bs) - ) - ) - else Left "Image is not 128x128" - where - is128 im = - let i = convertRGB8 im - in imageWidth i == 128 && imageHeight i == 128 +-- | @parseEmojiImage bs@ will attempt to convert the given image bytestring @bs@ +-- to the base64 format expected by the Discord API. It may return Left with an +-- error reason if either the bytestring is too large, or if the image format +-- could not be predetermined from the opening few bytes. This function does +-- /not/ validate the rest of the image, nor check that its dimensions are +-- 128x128 as required by Discord. This is up to the library user to check. +-- +-- This function accepts all file types accepted by 'getMimeType'. +parseEmojiImage :: B.ByteString -> Either T.Text (Base64Image Emoji) +parseEmojiImage bs + | B.length bs > 256000 = Left "Cannot create emoji - File is larger than 256kb" + | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs))) + | otherwise = Left "Unsupported image format provided" emojiMajorRoute :: EmojiRequest a -> String emojiMajorRoute c = case c of @@ -107,16 +81,16 @@ emojiJsonRequest :: EmojiRequest r -> JsonRequest emojiJsonRequest c = case c of - (ListGuildEmojis g) -> Get (guilds // g /: "emojis") mempty - (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty - (CreateGuildEmoji g name (EmojiImageParsed im)) -> + (ListGuildEmojis g) -> Get (guilds /~ g /: "emojis") mempty + (GetGuildEmoji g e) -> Get (guilds /~ g /: "emojis" /~ e) mempty + (CreateGuildEmoji g name b64im) -> Post - (guilds // g /: "emojis") + (guilds /~ g /: "emojis") ( pure ( R.ReqBodyJson ( object [ "name" .= name, - "image" .= im + "image" .= b64im -- todo , "roles" .= ... ] ) @@ -125,39 +99,46 @@ mempty (ModifyGuildEmoji g e o) -> Patch - (guilds // g /: "emojis" // e) + (guilds /~ g /: "emojis" /~ e) (pure (R.ReqBodyJson o)) mempty - (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty - -data StickerData = StickerDataPNG {stickerData :: B.ByteString} | StickerDataAPNG {stickerData :: B.ByteString} | StickerDataLOTTIE {stickerData :: B.ByteString} - deriving (Show, Read, Eq, Ord) + (DeleteGuildEmoji g e) -> Delete (guilds /~ g /: "emojis" /~ e) mempty -instance ToJSON StickerData where - toJSON sd = String $ "data:image/" <> sdt <> ";base64," <> TE.decodeUtf8 (B64.encode (stickerData sd)) - where - sdt = case sd of - StickerDataPNG _ -> "png" - StickerDataAPNG _ -> "apng" - StickerDataLOTTIE _ -> "lottie" +-- | @parseStickerImage bs@ accepts PNG, APNG, or Lottie JSON bytestring @bs@ and +-- will attempt to convert it to the base64 format expected by the Discord API. +-- It may return Left with an error reason if the image format is unexpected. +-- This function does /not/ validate the contents of the image, this is up to +-- the library user to check. +parseStickerImage :: B.ByteString -> Either T.Text (Base64Image Sticker) +parseStickerImage bs + | B.length bs > 512000 + = Left "Cannot create sticker - File is larger than 512kb" + | Just "image/png" <- getMimeType bs + = Right (Base64Image "image/png" (TE.decodeUtf8 (B64.encode bs))) + | not (B.null bs) && B.head bs == 0x7b -- '{' + = Right (Base64Image "application/json" (TE.decodeUtf8 (B64.encode bs))) + | otherwise + = Left "Unsupported image format provided" +-- | Options for `CreateGuildSticker` data CreateGuildStickerOpts = CreateGuildStickerOpts { guildStickerName :: T.Text, guildStickerDescription :: T.Text, guildStickerTags :: [T.Text], - guildStickerFile :: StickerData + guildStickerFile :: Base64Image Sticker } deriving (Show, Read, Eq, Ord) instance ToJSON CreateGuildStickerOpts where - toJSON CreateGuildStickerOpts {..} = + toJSON (CreateGuildStickerOpts name desc tags b64im) = object - [ ("name", toJSON guildStickerName), - ("description", toJSON guildStickerDescription), - ("tags", toJSON . T.intercalate "," $ guildStickerTags), - ("file", toJSON guildStickerFile) + [ ("name", toJSON name), + ("description", toJSON desc), + ("tags", toJSON $ T.intercalate "," tags), + ("file", toJSON b64im) ] +-- | Options for `ModifyGuildSticker` data EditGuildStickerOpts = EditGuildStickerOpts { editGuildStickerName :: Maybe T.Text, editGuildStickerDescription :: Maybe T.Text, @@ -212,12 +193,12 @@ stickerJsonRequest :: StickerRequest a -> JsonRequest stickerJsonRequest = \case - GetSticker gid -> Get (baseUrl /: "stickers" // gid) mempty + GetSticker gid -> Get (baseUrl /: "stickers" /~ gid) mempty ListNitroStickerPacks -> Get (baseUrl /: "sticker-packs") mempty ListGuildStickers gid -> Get (stickersGuild gid) mempty - GetGuildSticker gid sid -> Get (stickersGuild gid // sid) mempty + GetGuildSticker gid sid -> Get (stickersGuild gid /~ sid) mempty CreateGuildSticker gid cgso -> Post (stickersGuild gid) (pure $ R.ReqBodyJson $ toJSON cgso) mempty - ModifyGuildSticker gid sid egso -> Patch (stickersGuild gid // sid) (pure $ R.ReqBodyJson egso) mempty - DeleteGuildSticker gid sid -> Delete (stickersGuild gid // sid) mempty + ModifyGuildSticker gid sid egso -> Patch (stickersGuild gid /~ sid) (pure $ R.ReqBodyJson egso) mempty + DeleteGuildSticker gid sid -> Delete (stickersGuild gid /~ sid) mempty where - stickersGuild gid = baseUrl /: "guilds" // gid /: "stickers" + stickersGuild gid = baseUrl /: "guilds" /~ gid /: "stickers" diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs --- a/src/Discord/Internal/Rest/Guild.hs +++ b/src/Discord/Internal/Rest/Guild.hs @@ -20,7 +20,7 @@ import Data.Aeson -import Network.HTTP.Req ((/:)) +import Network.HTTP.Req ((/:), (/~)) import qualified Network.HTTP.Req as R import qualified Data.Text as T @@ -141,6 +141,7 @@ -- | Vanity URL GetGuildVanityURL :: GuildId -> GuildRequest T.Text +-- | Options for `ModifyGuildIntegration` data ModifyGuildIntegrationOpts = ModifyGuildIntegrationOpts { modifyGuildIntegrationOptsExpireBehavior :: Integer , modifyGuildIntegrationOptsExpireGraceSeconds :: Integer @@ -153,6 +154,7 @@ , ("expire_behavior", toJSON <$> pure modifyGuildIntegrationOptsExpireBehavior ) , ("enable_emoticons", toJSON <$> pure modifyGuildIntegrationOptsEmoticonsEnabled ) ]] +-- | Options for `CreateGuildIntegration` data CreateGuildIntegrationOpts = CreateGuildIntegrationOpts { createGuildIntegrationOptsType :: T.Text } deriving (Show, Read, Eq, Ord) @@ -161,6 +163,7 @@ toJSON CreateGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- [("type", toJSON <$> pure createGuildIntegrationOptsType ) ]] +-- | Options for `CreateGuildBan` data CreateGuildBanOpts = CreateGuildBanOpts { createGuildBanOptsDeleteLastNMessages :: Maybe Int , createGuildBanOptsReason :: Maybe T.Text @@ -172,6 +175,7 @@ toJSON <$> createGuildBanOptsDeleteLastNMessages ), ("reason", toJSON <$> createGuildBanOptsReason )]] +-- | Options for `ModifyGuildRole` data ModifyGuildRoleOpts = ModifyGuildRoleOpts { modifyGuildRoleOptsName :: Maybe T.Text , modifyGuildRoleOptsPermissions :: Maybe T.Text @@ -188,6 +192,7 @@ ("hoist", toJSON <$> modifyGuildRoleOptsSeparateSidebar ), ("mentionable", toJSON <$> modifyGuildRoleOptsMentionable )]] +-- | Options for `AddGuildMember` data AddGuildMemberOpts = AddGuildMemberOpts { addGuildMemberOptsAccessToken :: T.Text , addGuildMemberOptsNickname :: Maybe T.Text @@ -204,6 +209,7 @@ ("mute", toJSON <$> addGuildMemberOptsIsMuted ), ("deaf", toJSON <$> addGuildMemberOptsIsDeafened )]] +-- | Options for `ModifyGuildMember` data ModifyGuildMemberOpts = ModifyGuildMemberOpts { modifyGuildMemberOptsNickname :: Maybe T.Text , modifyGuildMemberOptsRoles :: Maybe [RoleId] @@ -225,19 +231,24 @@ ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel), ("communication_disabled_until", toJSON <$> modifyGuildMemberOptsTimeoutUntil)]] +-- | Options for `CreateGuildChannel` data CreateGuildChannelOpts + -- | Create a text channel = CreateGuildChannelOptsText { createGuildChannelOptsTopic :: Maybe T.Text , createGuildChannelOptsUserMessageRateDelay :: Maybe Integer , createGuildChannelOptsIsNSFW :: Maybe Bool , createGuildChannelOptsCategoryId :: Maybe ChannelId } + -- | Create a voice channel | CreateGuildChannelOptsVoice { createGuildChannelOptsBitrate :: Maybe Integer , createGuildChannelOptsMaxUsers :: Maybe Integer , createGuildChannelOptsCategoryId :: Maybe ChannelId } + -- | Create a category | CreateGuildChannelOptsCategory deriving (Show, Read, Eq, Ord) +-- | Converts a channel name, a list of permissions and other channel options into a JSON Value createChannelOptsToJSON :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value createChannelOptsToJSON name perms opts = object [(key, val) | (key, Just val) <- optsJSON] where @@ -263,7 +274,9 @@ ,("permission_overwrites", toJSON <$> Just perms)] --- | https://discord.com/developers/docs/resources/guild#modify-guild +-- | Options for `ModifyGuild` +-- +-- See data ModifyGuildOpts = ModifyGuildOpts { modifyGuildOptsName :: Maybe T.Text , modifyGuildOptsAFKChannelId :: Maybe ChannelId @@ -342,113 +355,113 @@ guildJsonRequest :: GuildRequest r -> JsonRequest guildJsonRequest c = case c of (GetGuild guild) -> - Get (guilds // guild) mempty + Get (guilds /~ guild) mempty (ModifyGuild guild patch) -> - Patch (guilds // guild) (pure (R.ReqBodyJson patch)) mempty + Patch (guilds /~ guild) (pure (R.ReqBodyJson patch)) mempty (DeleteGuild guild) -> - Delete (guilds // guild) mempty + Delete (guilds /~ guild) mempty (GetGuildChannels guild) -> - Get (guilds // guild /: "channels") mempty + Get (guilds /~ guild /: "channels") mempty (CreateGuildChannel guild name perms patch) -> - Post (guilds // guild /: "channels") + Post (guilds /~ guild /: "channels") (pure (R.ReqBodyJson (createChannelOptsToJSON name perms patch))) mempty (ModifyGuildChannelPositions guild newlocs) -> let patch = map (\(a, b) -> object [("id", toJSON a) ,("position", toJSON b)]) newlocs - in Patch (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + in Patch (guilds /~ guild /: "channels") (pure (R.ReqBodyJson patch)) mempty (GetGuildMember guild member) -> - Get (guilds // guild /: "members" // member) mempty + Get (guilds /~ guild /: "members" /~ member) mempty (ListGuildMembers guild range) -> - Get (guilds // guild /: "members") (guildMembersTimingToQuery range) + Get (guilds /~ guild /: "members") (guildMembersTimingToQuery range) (AddGuildMember guild user patch) -> - Put (guilds // guild /: "members" // user) (R.ReqBodyJson patch) mempty + Put (guilds /~ guild /: "members" /~ user) (R.ReqBodyJson patch) mempty (ModifyGuildMember guild member patch) -> - Patch (guilds // guild /: "members" // member) (pure (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") (pure (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 []) - in Put (guilds // guild /: "members" // user /: "roles" // role) body mempty + in Put (guilds /~ guild /: "members" /~ user /: "roles" /~ role) body mempty (RemoveGuildMemberRole guild user role) -> - Delete (guilds // guild /: "members" // user /: "roles" // role) mempty + Delete (guilds /~ guild /: "members" /~ user /: "roles" /~ role) mempty (RemoveGuildMember guild user) -> - Delete (guilds // guild /: "members" // user) mempty + Delete (guilds /~ guild /: "members" /~ user) mempty - (GetGuildBan guild user) -> Get (guilds // guild /: "bans" // user) mempty + (GetGuildBan guild user) -> Get (guilds /~ guild /: "bans" /~ user) mempty - (GetGuildBans guild) -> Get (guilds // guild /: "bans") mempty + (GetGuildBans guild) -> Get (guilds /~ guild /: "bans") mempty (CreateGuildBan guild user patch) -> - Put (guilds // guild /: "bans" // user) (R.ReqBodyJson patch) mempty + Put (guilds /~ guild /: "bans" /~ user) (R.ReqBodyJson patch) mempty (RemoveGuildBan guild ban) -> - Delete (guilds // guild /: "bans" // ban) mempty + Delete (guilds /~ guild /: "bans" /~ ban) mempty (GetGuildRoles guild) -> - Get (guilds // guild /: "roles") mempty + Get (guilds /~ guild /: "roles") mempty (CreateGuildRole guild patch) -> - Post (guilds // guild /: "roles") (pure (R.ReqBodyJson patch)) mempty + Post (guilds /~ guild /: "roles") (pure (R.ReqBodyJson patch)) mempty (ModifyGuildRolePositions guild patch) -> let body = map (\(role, pos) -> object ["id".=role, "position".=pos]) patch - in Patch (guilds // guild /: "roles") (pure (R.ReqBodyJson body)) mempty + in Patch (guilds /~ guild /: "roles") (pure (R.ReqBodyJson body)) mempty (ModifyGuildRole guild role patch) -> - Patch (guilds // guild /: "roles" // role) (pure (R.ReqBodyJson patch)) mempty + Patch (guilds /~ guild /: "roles" /~ role) (pure (R.ReqBodyJson patch)) mempty (DeleteGuildRole guild role) -> - Delete (guilds // guild /: "roles" // role) mempty + Delete (guilds /~ guild /: "roles" /~ role) mempty (GetGuildPruneCount guild days) -> - Get (guilds // guild /: "prune") ("days" R.=: days) + Get (guilds /~ guild /: "prune") ("days" R.=: days) (BeginGuildPrune guild days) -> - Post (guilds // guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) + Post (guilds /~ guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) (GetGuildVoiceRegions guild) -> - Get (guilds // guild /: "regions") mempty + Get (guilds /~ guild /: "regions") mempty (GetGuildInvites guild) -> - Get (guilds // guild /: "invites") mempty + Get (guilds /~ guild /: "invites") mempty (GetGuildIntegrations guild) -> - Get (guilds // guild /: "integrations") mempty + Get (guilds /~ guild /: "integrations") mempty (CreateGuildIntegration guild iid opts) -> let patch = object [("type" .= createGuildIntegrationOptsType opts) ,("id" .= iid)] - in Post (guilds // guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty + in Post (guilds /~ guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty (ModifyGuildIntegration guild iid patch) -> let body = pure (R.ReqBodyJson patch) - in Patch (guilds // guild /: "integrations" // iid) body mempty + in Patch (guilds /~ guild /: "integrations" /~ iid) body mempty (DeleteGuildIntegration guild integ) -> - Delete (guilds // guild /: "integrations" // integ) mempty + Delete (guilds /~ guild /: "integrations" /~ integ) mempty (SyncGuildIntegration guild integ) -> - Post (guilds // guild /: "integrations" // integ) (pure R.NoReqBody) mempty + Post (guilds /~ guild /: "integrations" /~ integ) (pure R.NoReqBody) mempty (GetGuildWidget guild) -> - Get (guilds // guild /: "integrations") mempty + Get (guilds /~ guild /: "integrations") mempty (ModifyGuildWidget guild patch) -> - Patch (guilds // guild /: "widget") (pure (R.ReqBodyJson patch)) mempty + Patch (guilds /~ guild /: "widget") (pure (R.ReqBodyJson patch)) mempty (GetGuildVanityURL guild) -> - Get (guilds // guild /: "vanity-url") mempty + Get (guilds /~ guild /: "vanity-url") mempty diff --git a/src/Discord/Internal/Rest/HTTP.hs b/src/Discord/Internal/Rest/HTTP.hs --- a/src/Discord/Internal/Rest/HTTP.hs +++ b/src/Discord/Internal/Rest/HTTP.hs @@ -31,11 +31,17 @@ import Discord.Internal.Types import Discord.Internal.Rest.Prelude -data RestCallInternalException = RestCallInternalErrorCode Int B.ByteString B.ByteString - | RestCallInternalNoParse String BL.ByteString - | RestCallInternalHttpException R.HttpException +-- | An exception in a Rest call +data RestCallInternalException + -- | Error code from Discord + = RestCallInternalErrorCode Int B.ByteString B.ByteString + -- | Couldn't parse the response + | RestCallInternalNoParse String BL.ByteString + -- | Something went bad in the HTTP process + | RestCallInternalHttpException R.HttpException deriving (Show) +-- | Rest event loop restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) -> Chan T.Text -> IO () restLoop auth urls log = loop M.empty diff --git a/src/Discord/Internal/Rest/Interactions.hs b/src/Discord/Internal/Rest/Interactions.hs --- a/src/Discord/Internal/Rest/Interactions.hs +++ b/src/Discord/Internal/Rest/Interactions.hs @@ -3,26 +3,42 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Discord.Internal.Rest.Interactions where +module Discord.Internal.Rest.Interactions (InteractionResponseRequest(..)) where import Data.Aeson (encode) import qualified Data.ByteString.Lazy as BL import Discord.Internal.Rest.Prelude + ( RestIO, + Request(..), + JsonRequest(Delete, Post, Get, Patch), + baseUrl) import Discord.Internal.Types import Discord.Internal.Types.Interactions import Network.HTTP.Client.MultipartFormData (PartM, partBS) -import Network.HTTP.Req ((/:)) +import Network.HTTP.Req ((/:), (/~)) import qualified Network.HTTP.Req as R -import qualified Data.Text as T +-- | Data constructor for Interaction response requests data InteractionResponseRequest a where + -- | Create a response to an Interaction from the gateway. + -- + -- This endpoint also supports file attachments similar to the webhook endpoints. + -- Refer to [Uploading files](https://discord.com/developers/docs/reference#uploading-files) + -- for details on uploading files and @multipart/form-data@ requests. CreateInteractionResponse :: InteractionId -> InteractionToken -> InteractionResponse -> InteractionResponseRequest () + -- | Returns the initial Interaction response. GetOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest Message + -- | Edits the initial Interaction response. EditOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message + -- | Deletes the initial Interaction response. DeleteOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest () + -- | Create a followup message for an Interaction CreateFollowupInteractionMessage :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message + -- | Returns a followup message for an Interaction. GetFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest Message + -- | Edits a followup message for an Interaction. EditFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponse -> InteractionResponseRequest Message + -- | Deletes a followup message for an Interaction. DeleteFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest () instance Request (InteractionResponseRequest a) where @@ -41,12 +57,12 @@ (DeleteFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid interaction :: ApplicationId -> InteractionToken -> R.Url 'R.Https -interaction aid it = baseUrl /: "webhooks" // aid /: fromToken it /: "messages" +interaction aid it = baseUrl /: "webhooks" /~ aid /~ it /: "messages" interactionResponseJsonRequest :: InteractionResponseRequest a -> JsonRequest interactionResponseJsonRequest a = case a of (CreateInteractionResponse iid it i) -> - Post (baseUrl /: "interactions" // iid /: fromToken it /: "callback") (convert i) mempty + Post (baseUrl /: "interactions" /~ iid /~ it /: "callback") (convert i) mempty (GetOriginalInteractionResponse aid it) -> Get (interaction aid it /: "@original") mempty (EditOriginalInteractionResponse aid it i) -> @@ -54,13 +70,13 @@ (DeleteOriginalInteractionResponse aid it) -> Delete (interaction aid it /: "@original") mempty (CreateFollowupInteractionMessage aid it i) -> - Post (baseUrl /: "webhooks" // aid /: fromToken it) (convertIRM i) mempty + Post (baseUrl /: "webhooks" /~ aid /~ it) (convertIRM i) mempty (GetFollowupInteractionMessage aid it mid) -> - Get (interaction aid it // mid) mempty + Get (interaction aid it /~ mid) mempty (EditFollowupInteractionMessage aid it mid i) -> - Patch (interaction aid it // mid) (convert i) mempty + Patch (interaction aid it /~ mid) (convert i) mempty (DeleteFollowupInteractionMessage aid it mid) -> - Delete (interaction aid it // mid) mempty + Delete (interaction aid it /~ mid) mempty where convert :: InteractionResponse -> RestIO R.ReqBodyMultipart convert ir@(InteractionResponseChannelMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) @@ -72,6 +88,3 @@ convert' InteractionResponseMessage {..} = case interactionResponseMessageEmbeds of Nothing -> [] Just f -> (maybeEmbed . Just) =<< f - -fromToken :: InteractionToken -> T.Text -fromToken (InteractionToken t) = t diff --git a/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs --- a/src/Discord/Internal/Rest/Prelude.hs +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -12,8 +12,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE - import qualified Network.HTTP.Req as R +import Web.Internal.HttpApiData (ToHttpApiData) import Discord.Internal.Types @@ -34,12 +34,13 @@ where -- | https://discord.com/developers/docs/reference#user-agent -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.13.0)" + agent = "DiscordBot (https://github.com/discord-haskell/discord-haskell, 1.14.0)" --- Append to an URL -infixl 5 // -(//) :: Show a => R.Url scheme -> a -> R.Url scheme -(//) url part = url R./: T.pack (show part) +-- Possibly append to an URL +infixl 5 /? +(/?) :: ToHttpApiData a => R.Url scheme -> Maybe a -> R.Url scheme +(/?) url Nothing = url +(/?) url (Just part) = url R./~ part -- | A compiled HTTP request ready to execute diff --git a/src/Discord/Internal/Rest/User.hs b/src/Discord/Internal/Rest/User.hs --- a/src/Discord/Internal/Rest/User.hs +++ b/src/Discord/Internal/Rest/User.hs @@ -7,19 +7,16 @@ -- | Provides actions for Channel API interactions module Discord.Internal.Rest.User ( UserRequest(..) - , parseCurrentUserAvatar - , CurrentUserAvatar + , parseAvatarImage ) where import Data.Aeson -import Codec.Picture -import Network.HTTP.Req ((/:)) +import Network.HTTP.Req ((/:), (/~)) import qualified Network.HTTP.Req as R import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base64 as B64 import Discord.Internal.Rest.Prelude @@ -39,7 +36,7 @@ -- | Returns a 'User' for a given user ID GetUser :: UserId -> UserRequest User -- | Modify user's username & avatar pic - ModifyCurrentUser :: T.Text -> CurrentUserAvatar -> UserRequest User + ModifyCurrentUser :: T.Text -> Base64Image User -> UserRequest User -- | Returns a list of user 'Guild' objects the current user is a member of. -- Requires the guilds OAuth2 scope. GetCurrentUserGuilds :: UserRequest [PartialGuild] @@ -52,17 +49,17 @@ GetUserConnections :: UserRequest [ConnectionObject] --- | Formatted avatar data https://discord.com/developers/docs/resources/user#avatar-data -data CurrentUserAvatar = CurrentUserAvatar T.Text - deriving (Show, Read, Eq, Ord) - -parseCurrentUserAvatar :: B.ByteString -> Either T.Text CurrentUserAvatar -parseCurrentUserAvatar bs = - case decodeImage bs of - Left e -> Left (T.pack e) - Right im -> Right $ CurrentUserAvatar $ "data:image/png;base64," - <> TE.decodeUtf8 (B64.encode (BL.toStrict (encodePng (convertRGBA8 im)))) - +-- | @parseAvatarImage bs@ will attempt to convert the given image bytestring +-- @bs@ to the base64 format expected by the Discord API. It may return Left +-- with an error reason if the image format could not be predetermined from the +-- opening magic bytes. This function does /not/ validate the rest of the image, +-- and this is up to the library user to check themselves. +-- +-- This function accepts all file types accepted by 'getMimeType'. +parseAvatarImage :: B.ByteString -> Either T.Text (Base64Image User) +parseAvatarImage bs + | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs))) + | otherwise = Left "Unsupported image format provided" userMajorRoute :: UserRequest a -> String userMajorRoute c = case c of @@ -82,15 +79,15 @@ userJsonRequest c = case c of (GetCurrentUser) -> Get (users /: "@me") mempty - (GetUser user) -> Get (users // user ) mempty + (GetUser user) -> Get (users /~ user ) mempty - (ModifyCurrentUser name (CurrentUserAvatar im)) -> + (ModifyCurrentUser name b64im) -> Patch (users /: "@me") (pure (R.ReqBodyJson (object [ "username" .= name - , "avatar" .= im ]))) mempty + , "avatar" .= b64im ]))) mempty (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty - (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" // guild) mempty + (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" /~ guild) mempty (GetUserDMs) -> Get (users /: "@me" /: "channels") mempty diff --git a/src/Discord/Internal/Rest/Voice.hs b/src/Discord/Internal/Rest/Voice.hs --- a/src/Discord/Internal/Rest/Voice.hs +++ b/src/Discord/Internal/Rest/Voice.hs @@ -20,8 +20,9 @@ majorRoute = voiceMajorRoute jsonRequest = voiceJsonRequest --- | Data constructor for requests. See +-- | Data constructor for requests data VoiceRequest a where + -- | List all available 'VoiceRegion's. ListVoiceRegions :: VoiceRequest [VoiceRegion] voiceMajorRoute :: VoiceRequest a -> String diff --git a/src/Discord/Internal/Rest/Webhook.hs b/src/Discord/Internal/Rest/Webhook.hs --- a/src/Discord/Internal/Rest/Webhook.hs +++ b/src/Discord/Internal/Rest/Webhook.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,7 +17,7 @@ import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Network.HTTP.Req ((/:)) +import Network.HTTP.Req ((/:), (/~)) import qualified Network.HTTP.Req as R import Network.HTTP.Client (RequestBody (RequestBodyBS)) import Network.HTTP.Client.MultipartFormData (partBS, partFileRequestBody) @@ -41,22 +40,67 @@ majorRoute = webhookMajorRoute jsonRequest = webhookJsonRequest --- | Data constructor for requests. See +-- | Data constructors for webhook requests. data WebhookRequest a where - CreateWebhook :: ChannelId -> CreateWebhookOpts -> WebhookRequest Webhook - GetChannelWebhooks :: ChannelId -> WebhookRequest [Webhook] - GetGuildWebhooks :: GuildId -> WebhookRequest [Webhook] - GetWebhook :: WebhookId -> WebhookRequest Webhook - GetWebhookWithToken :: WebhookId -> T.Text -> WebhookRequest Webhook - ModifyWebhook :: WebhookId -> ModifyWebhookOpts - -> WebhookRequest Webhook - ModifyWebhookWithToken :: WebhookId -> T.Text -> ModifyWebhookOpts - -> WebhookRequest Webhook - DeleteWebhook :: WebhookId -> WebhookRequest () - DeleteWebhookWithToken :: WebhookId -> T.Text -> WebhookRequest () - ExecuteWebhookWithToken :: WebhookId -> T.Text -> ExecuteWebhookWithTokenOpts - -> WebhookRequest () + -- | Creates a new webhook and returns a webhook object on success. Requires the @MANAGE_WEBHOOKS@ permission. + -- An error will be returned if a webhook name (name) is not valid. A webhook name is valid if: + -- + -- * It does not contain the substring @clyde@ (case-insensitive) + -- * It follows the nickname guidelines in the Usernames and Nicknames documentation, + -- with an exception that webhook names can be up to 80 characters + CreateWebhook :: ChannelId + -> CreateWebhookOpts + -> WebhookRequest Webhook + -- | Returns a channel's `Webhook`s as a list. Requires the @MANAGE_WEBHOOKS@ permission. + GetChannelWebhooks :: ChannelId + -> WebhookRequest [Webhook] + -- | Returns a guild's `Webhook`s as a list. Requires the @MANAGE_WEBHOOKS@ permission. + GetGuildWebhooks :: GuildId + -> WebhookRequest [Webhook] + -- | Returns the `Webhook` for the given id. If a token is given, authentication is not required. + GetWebhook :: WebhookId + -> Maybe WebhookToken + -> WebhookRequest Webhook + -- | Modify a webhook. Requires the @MANAGE_WEBHOOKS@ permission. Returns the updated `Webhook` on success. + -- If a token is given, authentication is not required. + ModifyWebhook :: WebhookId + -> Maybe WebhookToken + -> ModifyWebhookOpts + -> WebhookRequest Webhook + -- | Delete a webhook permanently. Requires the @MANAGE_WEBHOOKS@ permission. + -- If a token is given, authentication is not required. + DeleteWebhook :: WebhookId + -> Maybe WebhookToken + -> WebhookRequest () + -- | Executes a Webhook. + -- + -- Refer to [Uploading Files](https://discord.com/developers/docs/reference#uploading-files) + -- for details on attachments and @multipart/form-data@ requests. + ExecuteWebhook :: WebhookId + -> WebhookToken + -> ExecuteWebhookWithTokenOpts + -> WebhookRequest () + -- We don't support slack and github compatible webhooks because you should + -- just use execute webhook. + -- | Returns a previously-sent webhook message from the same token. + GetWebhookMessage :: WebhookId + -> WebhookToken + -> MessageId + -> WebhookRequest Message + -- | Edits a previously-sent webhook message from the same token. + EditWebhookMessage :: WebhookId + -> WebhookToken + -> MessageId + -> T.Text -- currently we don't support the full range of edits - feel free to PR and fix this + -> WebhookRequest Message + -- | Deletes a previously-sent webhook message from the same token. + DeleteWebhookMessage :: WebhookId + -> WebhookToken + -> MessageId + -> WebhookRequest () + +-- | Options for `ModifyWebhook` and `ModifyWebhookWithToken` data ModifyWebhookOpts = ModifyWebhookOpts { modifyWebhookOptsName :: Maybe T.Text , modifyWebhookOptsAvatar :: Maybe T.Text @@ -69,6 +113,7 @@ ("name", toJSON <$> modifyWebhookOptsName), ("avatar", toJSON <$> modifyWebhookOptsAvatar) ] ] +-- | Options for `CreateWebhook` data CreateWebhookOpts = CreateWebhookOpts { createWebhookOptsName :: T.Text , createWebhookOptsAvatar :: Maybe T.Text @@ -79,11 +124,13 @@ [("name", toJSON <$> Just createWebhookOptsName), ("avatar", toJSON <$> createWebhookOptsAvatar) ] ] +-- | Options for `ExecuteWebhookWithToken` data ExecuteWebhookWithTokenOpts = ExecuteWebhookWithTokenOpts { executeWebhookWithTokenOptsUsername :: Maybe T.Text , executeWebhookWithTokenOptsContent :: WebhookContent } deriving (Show, Read, Eq, Ord) +-- | A webhook's content data WebhookContent = WebhookContentText T.Text | WebhookContentFile T.Text B.ByteString | WebhookContentEmbeds [CreateEmbed] @@ -100,59 +147,51 @@ [("username", toJSON <$> executeWebhookWithTokenOptsUsername)] <> webhookContentJson executeWebhookWithTokenOptsContent ] - +-- | Major routes for webhook requests webhookMajorRoute :: WebhookRequest a -> String webhookMajorRoute ch = case ch of - (CreateWebhook c _) -> "aaaaaahook " <> show c - (GetChannelWebhooks c) -> "aaaaaahook " <> show c - (GetGuildWebhooks g) -> "aaaaaahook " <> show g - (GetWebhook w) -> "aaaaaahook " <> show w - (GetWebhookWithToken w _) -> "getwebhook " <> show w - (ModifyWebhook w _) -> "modifyhook " <> show w - (ModifyWebhookWithToken w _ _) -> "modifyhook " <> show w - (DeleteWebhook w) -> "deletehook " <> show w - (DeleteWebhookWithToken w _) -> "deletehook " <> show w - (ExecuteWebhookWithToken w _ _) -> "executehk " <> show w + (CreateWebhook c _) -> "aaaaaahook " <> show c + (GetChannelWebhooks c) -> "aaaaaahook " <> show c + (GetGuildWebhooks g) -> "aaaaaahook " <> show g + (GetWebhook w _) -> "getwebhook " <> show w + (ModifyWebhook w _ _) -> "modifyhook " <> show w + (DeleteWebhook w _) -> "deletehook " <> show w + (ExecuteWebhook w _ _) -> "executehk " <> show w + (GetWebhookMessage w _ _) -> "gethkmsg " <> show w + (EditWebhookMessage w _ _ _) -> "edithkmsg " <> show w + (DeleteWebhookMessage w _ _) -> "delhkmsg " <> show w +-- | Create a 'JsonRequest' from a `WebhookRequest` webhookJsonRequest :: WebhookRequest r -> JsonRequest webhookJsonRequest ch = case ch of (CreateWebhook channel patch) -> let body = pure (R.ReqBodyJson patch) - in Post (baseUrl /: "channels" // channel /: "webhooks") body mempty + in Post (baseUrl /: "channels" /~ channel /: "webhooks") body mempty (GetChannelWebhooks c) -> - Get (baseUrl /: "channels" // c /: "webhooks") mempty + Get (baseUrl /: "channels" /~ c /: "webhooks") mempty (GetGuildWebhooks g) -> - Get (baseUrl /: "guilds" // g /: "webhooks") mempty - - (GetWebhook w) -> - Get (baseUrl /: "webhooks" // w) mempty - - (GetWebhookWithToken w t) -> - Get (baseUrl /: "webhooks" // w /: t) mempty - - (ModifyWebhook w patch) -> - Patch (baseUrl /: "webhooks" // w) (pure (R.ReqBodyJson patch)) mempty + Get (baseUrl /: "guilds" /~ g /: "webhooks") mempty - (ModifyWebhookWithToken w t p) -> - Patch (baseUrl /: "webhooks" // w /: t) (pure (R.ReqBodyJson p)) mempty + (GetWebhook w t) -> + Get (baseUrl /: "webhooks" /~ w /? t) mempty - (DeleteWebhook w) -> - Delete (baseUrl /: "webhooks" // w) mempty + (ModifyWebhook w t p) -> + Patch (baseUrl /: "webhooks" /~ w /? t) (pure (R.ReqBodyJson p)) mempty - (DeleteWebhookWithToken w t) -> - Delete (baseUrl /: "webhooks" // w /: t) mempty + (DeleteWebhook w t) -> + Delete (baseUrl /: "webhooks" /~ w /? t) mempty - (ExecuteWebhookWithToken w tok o) -> + (ExecuteWebhook w tok o) -> case executeWebhookWithTokenOptsContent o of WebhookContentFile name text -> let part = partFileRequestBody "file" (T.unpack name) (RequestBodyBS text) body = R.reqBodyMultipart [part] - in Post (baseUrl /: "webhooks" // w /: tok) body mempty + in Post (baseUrl /: "webhooks" /~ w /~ tok) body mempty WebhookContentText _ -> let body = pure (R.ReqBodyJson o) - in Post (baseUrl /: "webhooks" // w /: tok) body mempty + 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)) <- @@ -163,4 +202,13 @@ 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 + in Post (baseUrl /: "webhooks" /~ w /: unToken tok) body mempty + + (GetWebhookMessage w t m) -> + Get (baseUrl /: "webhooks" /~ w /~ t /: "messages" /~ m) mempty + + (EditWebhookMessage w t m p) -> + Patch (baseUrl /: "webhooks" /~ w /~ t /: "messages" /~ m) (pure (R.ReqBodyJson $ object ["content" .= p])) mempty + + (DeleteWebhookMessage w t m) -> + Delete (baseUrl /: "webhooks" /~ w /~ t /: "messages" /~ m) mempty diff --git a/src/Discord/Internal/Types.hs b/src/Discord/Internal/Types.hs --- a/src/Discord/Internal/Types.hs +++ b/src/Discord/Internal/Types.hs @@ -29,6 +29,7 @@ import Discord.Internal.Types.Prelude import Discord.Internal.Types.User +-- | Converts an internal event to its user facing counterpart userFacingEvent :: EventInternalParse -> Event userFacingEvent event = case event of InternalReady a b c d e f g -> Ready a b c d e f g diff --git a/src/Discord/Internal/Types/ApplicationCommands.hs b/src/Discord/Internal/Types/ApplicationCommands.hs --- a/src/Discord/Internal/Types/ApplicationCommands.hs +++ b/src/Discord/Internal/Types/ApplicationCommands.hs @@ -401,6 +401,10 @@ createDescription :: T.Text, -- | What options the application (max length 25). createOptions :: Maybe Options, + -- | The default permissions required for members set when using the command + -- in a guild. + -- Set of permissions represented as a bit set. + createDefaultMemberPermissions :: Maybe T.Text, -- | Whether the command is enabled by default when the application is added -- to a guild. createDefaultPermission :: Bool @@ -408,6 +412,10 @@ | CreateApplicationCommandUser { -- | The application command name (1-32 chars). createName :: T.Text, + -- | The default permissions required for members set when using the command + -- in a guild. + -- Set of permissions represented as a bit set. + createDefaultMemberPermissions :: Maybe T.Text, -- | Whether the command is enabled by default when the application is added -- to a guild. createDefaultPermission :: Bool @@ -415,6 +423,10 @@ | CreateApplicationCommandMessage { -- | The application command name (1-32 chars). createName :: T.Text, + -- | The default permissions required for members set when using the command + -- in a guild. + -- Set of permissions represented as a bit set. + createDefaultMemberPermissions :: Maybe T.Text, -- | Whether the command is enabled by default when the application is added -- to a guild. createDefaultPermission :: Bool @@ -429,6 +441,7 @@ [ ("name", toMaybeJSON createName), ("description", toMaybeJSON createDescription), ("options", toJSON <$> createOptions), + ("default_member_permissions", toMaybeJSON createDefaultMemberPermissions), ("default_permission", toMaybeJSON createDefaultPermission), ("type", Just $ Number 1) ] @@ -438,6 +451,7 @@ [ (name, value) | (name, Just value) <- [ ("name", toMaybeJSON createName), + ("default_member_permissions", toMaybeJSON createDefaultMemberPermissions), ("default_permission", toMaybeJSON createDefaultPermission), ("type", Just $ Number 2) ] @@ -447,6 +461,7 @@ [ (name, value) | (name, Just value) <- [ ("name", toMaybeJSON createName), + ("default_member_permissions", toMaybeJSON createDefaultMemberPermissions), ("default_permission", toMaybeJSON createDefaultPermission), ("type", Just $ Number 3) ] @@ -464,21 +479,21 @@ -- than or equal to 100 characters. createChatInput :: T.Text -> T.Text -> Maybe CreateApplicationCommand createChatInput name desc - | nameIsValid True name && not (T.null desc) && T.length desc <= 100 = Just $ CreateApplicationCommandChatInput name desc Nothing True + | nameIsValid True name && not (T.null desc) && T.length desc <= 100 = Just $ CreateApplicationCommandChatInput name desc Nothing Nothing True | otherwise = Nothing -- | Create the basics for a user command. Use record overwriting to enter the -- other values. The name needs to be between 1 and 32 characters. createUser :: T.Text -> Maybe CreateApplicationCommand createUser name - | nameIsValid False name = Just $ CreateApplicationCommandUser name True + | nameIsValid False name = Just $ CreateApplicationCommandUser name Nothing True | otherwise = Nothing -- | Create the basics for a message command. Use record overwriting to enter -- the other values. The name needs to be between 1 and 32 characters. createMessage :: T.Text -> Maybe CreateApplicationCommand createMessage name - | nameIsValid False name = Just $ CreateApplicationCommandMessage name True + | nameIsValid False name = Just $ CreateApplicationCommandMessage name Nothing True | otherwise = Nothing -- | Data type to be used when editing application commands. The specification diff --git a/src/Discord/Internal/Types/Channel.hs b/src/Discord/Internal/Types/Channel.hs --- a/src/Discord/Internal/Types/Channel.hs +++ b/src/Discord/Internal/Types/Channel.hs @@ -25,111 +25,121 @@ data Channel -- | A text channel in a guild. = ChannelText - { channelId :: ChannelId -- ^ The id of the channel (Will be equal to - -- the guild if it's the "general" channel). - , channelGuild :: GuildId -- ^ The id of the guild. - , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters). - , channelPosition :: Integer -- ^ The storing position of the channel. - , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's - , channelUserRateLimit :: Integer -- ^ Seconds before a user can speak again - , channelNSFW :: Bool -- ^ Is not-safe-for-work - , channelTopic :: T.Text -- ^ The topic of the channel. (0 - 1024 chars). + { channelId :: ChannelId -- ^ The id of the channel (Will be equal to + -- the guild if it's the "general" channel). + , channelGuild :: GuildId -- ^ The id of the guild. + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelPosition :: Integer -- ^ The storing position of the channel. + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's + , channelUserRateLimit :: Integer -- ^ Seconds before a user can speak again + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelTopic :: T.Text -- ^ The topic of the channel. (0 - 1024 chars). , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the -- channel , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) } + -- | A news Channel in a guild. | ChannelNews - { channelId :: ChannelId - , channelGuild :: GuildId - , channelName :: T.Text - , channelPosition :: Integer - , channelPermissions :: [Overwrite] - , channelNSFW :: Bool - , channelTopic :: T.Text - , channelLastMessage :: Maybe MessageId + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters) + , channelPosition :: Integer -- ^ The position of the channel + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overrite's + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelTopic :: T.Text -- ^ Topic of the channel (0 - 1024 characters) + , channelLastMessage :: Maybe MessageId -- ^ The ID of the last message of the channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) } + -- | A store page channel in a guild | ChannelStorePage - { channelId :: ChannelId - , channelGuild :: GuildId - , channelName :: T.Text - , channelPosition :: Integer - , channelNSFW :: Bool - , channelPermissions :: [Overwrite] - , channelParentId :: Maybe ParentId + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters) + , channelPosition :: Integer -- ^ The position of the channel + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overrite's + , channelParentId :: Maybe ParentId -- ^ The id of the parrent channel (category) } -- | A voice channel in a guild. | ChannelVoice - { channelId :: ChannelId - , channelGuild :: GuildId - , channelName :: T.Text - , channelPosition :: Integer - , channelPermissions :: [Overwrite] - , channelNSFW :: Bool - , channelBitRate :: Integer -- ^ The bitrate (in bits) of the channel. - , channelUserLimit :: Integer -- ^ The user limit of the voice channel. - , channelParentId :: Maybe ParentId + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelName :: T.Text -- ^ The name of the channel (2 - 1000) characters + , channelPosition :: Integer -- ^ The position of the channel + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overrite's + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelBitRate :: Integer -- ^ The bitrate (in bps) of the channel. + , channelUserLimit :: Integer -- ^ The user limit of the voice channel. + , channelParentId :: Maybe ParentId -- ^ The id of the parrent channel (category) } -- | DM Channels represent a one-to-one conversation between two users, outside the scope -- of guilds | ChannelDirectMessage - { channelId :: ChannelId - , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). - , channelLastMessage :: Maybe MessageId + { channelId :: ChannelId -- ^ The id of the channel + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). + , channelLastMessage :: Maybe MessageId -- ^ The last message sent to the channel } + -- | Like a 'ChannelDirectMessage' but for more people | ChannelGroupDM - { channelId :: ChannelId - , channelRecipients :: [User] - , channelLastMessage :: Maybe MessageId + { channelId :: ChannelId -- ^ The id of the channel + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipent(s). + , channelLastMessage :: Maybe MessageId -- ^ The last message sent to the channel } + -- | A channel category | ChannelGuildCategory - { channelId :: ChannelId - , channelGuild :: GuildId - , channelName :: T.Text - , channelPosition :: Integer - , channelPermissions :: [Overwrite] + { channelId :: ChannelId -- ^ The id of the category + , channelGuild :: GuildId -- ^ The id of the gild + , channelName :: T.Text -- ^ The name of the category + , channelPosition :: Integer -- ^ The position of the category + , channelPermissions :: [Overwrite] -- ^ A list of permission 'Overrite's } + -- | A stage channel | ChannelStage - { channelId :: ChannelId - , channelGuild :: GuildId - , channelStageId :: StageId - , channelStageTopic :: Text + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelStageId :: StageId -- ^ The id of the stage + , channelStageTopic :: Text -- ^ The topic text } + -- | A news Thread | ChannelNewsThread - { channelId :: ChannelId -- ^ The id of the thread - , channelGuild :: GuildId -- ^ The id of the guild. - , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again - , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the - -- channel - , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread - , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread } + -- | A thread anyone can join | ChannelPublicThread - { channelId :: ChannelId -- ^ The id of the thread - , channelGuild :: GuildId -- ^ The id of the guild. - , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again - , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the - -- channel - , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread - , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread } + -- | An on-invite thread | ChannelPrivateThread - { channelId :: ChannelId -- ^ The id of the thread - , channelGuild :: GuildId -- ^ The id of the guild. - , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again - , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the - -- channel - , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread - , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread } + -- | A channel of unknown type | ChannelUnknownType - { channelId :: ChannelId - , channelJSON :: Text + { channelId :: ChannelId -- ^ The id of the channel + , channelJSON :: Text -- ^ The library couldn't parse the channel type, here is the raw JSON } deriving (Show, Read, Eq, Ord) instance FromJSON Channel where @@ -180,6 +190,7 @@ <*> o .:? "nsfw" .!= False <*> o .:? "topic" .!= "" <*> o .:? "last_message_id" + <*> o .:? "parent_id" 6 -> ChannelStorePage <$> o .: "id" <*> o .:? "guild_id" .!= 0 @@ -244,7 +255,7 @@ , ("nsfw", toJSON <$> pure channelNSFW) , ("topic", toJSON <$> pure channelTopic) , ("last_message_id", toJSON <$> channelLastMessage) - + , ("parent_id", toJSON <$> channelParentId) ] ] toJSON ChannelStorePage{..} = object [(name,value) | (name, Just value) <- [ ("type", Just (Number 6)) @@ -344,23 +355,26 @@ -- | Permission overwrites for a channel. data Overwrite = Overwrite - { overwriteId :: OverwriteId -- ^ 'Role' or 'User' id - , overwriteType :: Integer -- ^ Either role (0) or member (1) - , overwriteAllow :: T.Text -- ^ Allowed permission bit set - , overwriteDeny :: T.Text -- ^ Denied permission bit set + { overwriteId :: Either RoleId UserId -- ^ 'Role' or 'User' id + , overwriteAllow :: T.Text -- ^ Allowed permission bit set + , overwriteDeny :: T.Text -- ^ Denied permission bit set } deriving (Show, Read, Eq, Ord) instance FromJSON Overwrite where - parseJSON = withObject "Overwrite" $ \o -> - Overwrite <$> o .: "id" - <*> o .: "type" - <*> o .: "allow" + parseJSON = withObject "Overwrite" $ \o -> do + t <- o .: "type" + i <- case (t :: Int) of + 0 -> Left <$> o .: "id" + 1 -> Right <$> o .: "id" + _ -> error "Type field can only be 0 (role id) or 1 (user id)" + Overwrite i + <$> o .: "allow" <*> o .: "deny" instance ToJSON Overwrite where toJSON Overwrite{..} = object - [ ("id", toJSON overwriteId) - , ("type", toJSON overwriteType) + [ ("id", toJSON $ either unId unId overwriteId) + , ("type", toJSON $ (either (const 0) (const 1) overwriteId :: Int)) , ("allow", toJSON overwriteAllow) , ("deny", toJSON overwriteDeny) ] @@ -394,6 +408,7 @@ , ("create_timestamp", toJSON <$> pure threadMetadataCreateTime) ] ] +-- | A user in a thread data ThreadMember = ThreadMember { threadMemberThreadId :: Maybe ChannelId -- ^ id of the thread , threadMemberUserId :: Maybe UserId -- ^ id of the user @@ -416,6 +431,7 @@ , ("flags", toJSON <$> pure threadMemberFlags) ] ] + data ThreadListSyncFields = ThreadListSyncFields { threadListSyncFieldsGuildId :: GuildId , threadListSyncFieldsChannelIds :: Maybe [ChannelId] @@ -557,12 +573,12 @@ -- | Data constructor for a part of MessageDetailedOpts. data AllowedMentions = AllowedMentions - { mentionEveryone :: Bool - , mentionUsers :: Bool - , mentionRoles :: Bool - , mentionUserIds :: [UserId] - , mentionRoleIds :: [RoleId] - , mentionRepliedUser :: Bool + { mentionEveryone :: Bool -- ^ Can mention @\@everyone@ + , mentionUsers :: Bool -- ^ Can mention any user + , mentionRoles :: Bool -- ^ Can mention any mentionable role + , mentionUserIds :: [UserId] -- ^ List of users able to be mentionned + , mentionRoleIds :: [RoleId] -- ^ List of roles able to be mentioneed + , mentionRepliedUser :: Bool -- ^ Can mention the sender of the replied message } deriving (Show, Read, Eq, Ord) instance Default AllowedMentions where @@ -586,8 +602,9 @@ "users" .= mentionUserIds, "replied_user" .= mentionRepliedUser ] +-- | A reaction to a message data MessageReaction = MessageReaction - { messageReactionCount :: Int + { messageReactionCount :: Int , messageReactionMeIncluded :: Bool , messageReactionEmoji :: Emoji } deriving (Show, Read, Eq, Ord) diff --git a/src/Discord/Internal/Types/Color.hs b/src/Discord/Internal/Types/Color.hs --- a/src/Discord/Internal/Types/Color.hs +++ b/src/Discord/Internal/Types/Color.hs @@ -22,7 +22,8 @@ -- All discord embed color stuff is credited to -- https://github.com/WarwickTabletop/tablebot/pull/34 data DiscordColor - = DiscordColorRGB Integer Integer Integer + = -- | An RGB color with values in @[0..255]@ + DiscordColorRGB Integer Integer Integer | DiscordColorDefault | DiscordColorAqua | DiscordColorDarkAqua @@ -95,6 +96,7 @@ let (r, g, b) = fromMaybe (0, 0, 0) $ hexToRGB hex in DiscordColorRGB r g b +-- | Convert a color to its internal `Integer` representation colorToInternal :: DiscordColor -> Integer -- colorToInternal (DiscordColor i) = i colorToInternal (DiscordColorRGB r g b) = (r * 256 + g) * 256 + b @@ -133,6 +135,7 @@ colorToInternal DiscordColorDiscordRed = 15548997 colorToInternal DiscordColorDiscordBlack = 16777215 +-- | Convert a color integer to a RGB color with values in @[0..255]@ convertToRGB :: Integer -> DiscordColor convertToRGB i = DiscordColorRGB (div i (256 * 256) .&. 255) (div i 256 .&. 255) (i .&. 255) diff --git a/src/Discord/Internal/Types/Components.hs b/src/Discord/Internal/Types/Components.hs --- a/src/Discord/Internal/Types/Components.hs +++ b/src/Discord/Internal/Types/Components.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +-- | Message components module Discord.Internal.Types.Components ( ActionRow (..), Button (..), @@ -28,6 +29,7 @@ import Discord.Internal.Types.Emoji (Emoji) import Discord.Internal.Types.Prelude (toMaybeJSON) +-- | Container for other message Components data ActionRow = ActionRowButtons [Button] | ActionRowSelectMenu SelectMenu deriving (Show, Read, Eq, Ord) @@ -329,5 +331,6 @@ <*> o .:? "placeholder" .!= "" _ -> fail "expected text input, found other type of component" +-- | Create a text input from an id and a label mkTextInput :: T.Text -> T.Text -> TextInput mkTextInput cid label = TextInput cid False label Nothing Nothing True "" "" diff --git a/src/Discord/Internal/Types/Emoji.hs b/src/Discord/Internal/Types/Emoji.hs --- a/src/Discord/Internal/Types/Emoji.hs +++ b/src/Discord/Internal/Types/Emoji.hs @@ -150,6 +150,7 @@ ("format_type", toJSON stickerItemFormatType) ] +-- | The format of a sticker data StickerFormatType = StickerFormatTypePNG | StickerFormatTypeAPNG diff --git a/src/Discord/Internal/Types/Events.hs b/src/Discord/Internal/Types/Events.hs --- a/src/Discord/Internal/Types/Events.hs +++ b/src/Discord/Internal/Types/Events.hs @@ -21,50 +21,91 @@ import Discord.Internal.Types.Emoji (Emoji) --- | Represents possible events sent by discord. Detailed information can be found at https://discord.com/developers/docs/topics/gateway. +-- | Represents possible events sent by discord. Detailed information can be found at . data Event = + -- | Contains the initial state information Ready Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication + -- | Response to a @Resume@ gateway command | Resumed [T.Text] + -- | new guild channel created | ChannelCreate Channel + -- | channel was updated | ChannelUpdate Channel + -- | channel was deleted | ChannelDelete Channel + -- | thread created, also sent when being added to a private thread | ThreadCreate Channel + -- | thread was updated | ThreadUpdate Channel + -- | thread was deleted | ThreadDelete Channel - | ThreadListSync ThreadListSyncFields - | ThreadMembersUpdate ThreadMembersUpdateFields + -- | sent when gaining access to a channel, contains all active threads in that channel + | ThreadListSync ThreadListSyncFields + -- | thread member for the current user was updated + | ThreadMembersUpdate ThreadMembersUpdateFields + -- | message was pinned or unpinned | ChannelPinsUpdate ChannelId (Maybe UTCTime) + -- | lazy-load for unavailable guild, guild became available, or user joined a new guild | GuildCreate Guild + -- | guild was updated | GuildUpdate Guild + -- | guild became unavailable, or user left/was removed from a guild | GuildDelete GuildUnavailable + -- | user was banned from a guild | GuildBanAdd GuildId User + -- | user was unbanned from a guild | GuildBanRemove GuildId User + -- | guild emojis were updated | GuildEmojiUpdate GuildId [Emoji] + -- | guild integration was updated | GuildIntegrationsUpdate GuildId + -- | new user joined a guild | GuildMemberAdd GuildId GuildMember + -- | user was removed from a guild | GuildMemberRemove GuildId User + -- | guild member was updated | GuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + -- | response to @Request Guild Members@ gateway command | GuildMemberChunk GuildId [GuildMember] + -- | guild role was created | GuildRoleCreate GuildId Role + -- | guild role was updated | GuildRoleUpdate GuildId Role + -- | guild role was deleted | GuildRoleDelete GuildId RoleId + -- | message was created | MessageCreate Message + -- | message was updated | MessageUpdate ChannelId MessageId + -- | message was deleted | MessageDelete ChannelId MessageId + -- | multiple messages were deleted at once | MessageDeleteBulk ChannelId [MessageId] + -- | user reacted to a message | MessageReactionAdd ReactionInfo + -- | user removed a reaction from a message | MessageReactionRemove ReactionInfo + -- | all reactions were explicitly removed from a message | MessageReactionRemoveAll ChannelId MessageId + -- | all reactions for a given emoji were explicitly removed from a message | MessageReactionRemoveEmoji ReactionRemoveInfo + -- | user was updated | PresenceUpdate PresenceInfo + -- | user started typing in a channel | TypingStart TypingInfo + -- | properties about the user changed | UserUpdate User + -- | someone joined, left, or moved a voice channel | InteractionCreate Interaction - -- | VoiceStateUpdate - -- | VoiceServerUpdate + -- | VoiceStateUpdate + -- | VoiceServerUpdate + -- | An Unknown Event, none of the others | UnknownEvent T.Text Object deriving (Show, Eq) +-- | Internal Event representation. Each matches to the corresponding constructor of `Event`. +-- +-- An application should never have to use those directly data EventInternalParse = InternalReady Int User [Channel] [GuildUnavailable] T.Text (Maybe Shard) PartialApplication | InternalResumed [T.Text] @@ -103,11 +144,12 @@ | InternalTypingStart TypingInfo | InternalUserUpdate User | InternalInteractionCreate Interaction - -- -- | InternalVoiceStateUpdate - -- -- | InternalVoiceServerUpdate + -- | InternalVoiceStateUpdate + -- | InternalVoiceServerUpdate | InternalUnknownEvent T.Text Object deriving (Show, Eq, Read) +-- | Structure containing partial information about an Application data PartialApplication = PartialApplication { partialApplicationID :: ApplicationId , partialApplicationFlags :: Int @@ -116,12 +158,13 @@ instance FromJSON PartialApplication where parseJSON = withObject "PartialApplication" (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") +-- | Structure containing information about a reaction data ReactionInfo = ReactionInfo - { reactionUserId :: UserId - , reactionGuildId :: Maybe GuildId - , reactionChannelId :: ChannelId - , reactionMessageId :: MessageId - , reactionEmoji :: Emoji + { reactionUserId :: UserId -- ^ User who reacted + , reactionGuildId :: Maybe GuildId -- ^ Guild in which the reacted message is (if any) + , reactionChannelId :: ChannelId -- ^ Channel in which the reacted message is + , reactionMessageId :: MessageId -- ^ The reacted message + , reactionEmoji :: Emoji -- ^ The Emoji used for the reaction } deriving (Show, Read, Eq, Ord) instance FromJSON ReactionInfo where @@ -132,6 +175,7 @@ <*> o .: "message_id" <*> o .: "emoji" +-- | Structure containing information about a reaction that has been removed data ReactionRemoveInfo = ReactionRemoveInfo { reactionRemoveChannelId :: ChannelId , reactionRemoveGuildId :: GuildId @@ -146,6 +190,7 @@ <*> o .: "message_id" <*> o .: "emoji" +-- | Structre containing typing status information data TypingInfo = TypingInfo { typingUserId :: UserId , typingChannelId :: ChannelId @@ -168,6 +213,7 @@ Left r -> fail r Right b -> pure b +-- | Parse an event from name and JSON data eventParse :: T.Text -> Object -> Parser EventInternalParse eventParse t o = case t of "READY" -> InternalReady <$> o .: "v" diff --git a/src/Discord/Internal/Types/Gateway.hs b/src/Discord/Internal/Types/Gateway.hs --- a/src/Discord/Internal/Types/Gateway.hs +++ b/src/Discord/Internal/Types/Gateway.hs @@ -22,7 +22,7 @@ import Discord.Internal.Types.Events import Discord.Internal.Types.Guild (Activity (..)) --- | Sent by gateway +-- | Messages that can be sent by gateway to the library data GatewayReceivable = Dispatch EventInternalParse Integer | HeartbeatRequest Integer @@ -41,7 +41,10 @@ deriving (Show, Read, Eq, Ord) --- | https://discord.com/developers/docs/topics/gateway#list-of-intents +-- | Gateway intents to subrscribe to +-- +-- Details of which intent englobs what data is avalilable at +-- [the official Discord documentation](https://discord.com/developers/docs/topics/gateway#list-of-intents) data GatewayIntent = GatewayIntent { gatewayIntentGuilds :: Bool , gatewayIntentMembers :: Bool @@ -51,7 +54,7 @@ , gatewayIntentWebhooks :: Bool , gatewayIntentInvites :: Bool , gatewayIntentVoiceStates :: Bool - , gatewayIntentPrecenses :: Bool + , gatewayIntentPresences :: Bool , gatewayIntentMessageChanges :: Bool , gatewayIntentMessageReactions :: Bool , gatewayIntentMessageTyping :: Bool @@ -70,7 +73,7 @@ , gatewayIntentWebhooks = True , gatewayIntentInvites = True , gatewayIntentVoiceStates = True - , gatewayIntentPrecenses = False -- false + , gatewayIntentPresences = False -- false , gatewayIntentMessageChanges = True , gatewayIntentMessageReactions = True , gatewayIntentMessageTyping = True @@ -91,7 +94,7 @@ , (2 ^ 5, gatewayIntentWebhooks) , (2 ^ 6, gatewayIntentInvites) , (2 ^ 7, gatewayIntentVoiceStates) - , (2 ^ 8, gatewayIntentPrecenses) + , (2 ^ 8, gatewayIntentPresences) , (2 ^ 9, gatewayIntentMessageChanges) , (2 ^ 10, gatewayIntentMessageReactions) , (2 ^ 11, gatewayIntentMessageTyping) @@ -109,12 +112,14 @@ | UpdateStatusVoice UpdateStatusVoiceOpts deriving (Show, Read, Eq, Ord) +-- | Options for `RequestGuildMembers` data RequestGuildMembersOpts = RequestGuildMembersOpts { requestGuildMembersOptsGuildId :: GuildId , requestGuildMembersOptsNamesStartingWith :: T.Text , requestGuildMembersOptsLimit :: Integer } deriving (Show, Read, Eq, Ord) +-- | Options for `UpdateStatusVoice` data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts { updateStatusVoiceOptsGuildId :: GuildId , updateStatusVoiceOptsChannelId :: Maybe ChannelId @@ -123,6 +128,7 @@ } deriving (Show, Read, Eq, Ord) +-- | Options for `UpdateStatus` data UpdateStatusOpts = UpdateStatusOpts { updateStatusOptsSince :: Maybe UTCTime , updateStatusOptsGame :: Maybe Activity @@ -131,6 +137,7 @@ } deriving (Show, Read, Eq, Ord) +-- | Possible values for `updateStatusOptsNewStatus` data UpdateStatusType = UpdateStatusOnline | UpdateStatusDoNotDisturb | UpdateStatusAwayFromKeyboard @@ -138,6 +145,8 @@ | UpdateStatusOffline deriving (Show, Read, Eq, Ord, Enum) + +-- | Converts an UpdateStatusType to a textual representation statusString :: UpdateStatusType -> T.Text statusString s = case s of UpdateStatusOnline -> "online" diff --git a/src/Discord/Internal/Types/Prelude.hs b/src/Discord/Internal/Types/Prelude.hs --- a/src/Discord/Internal/Types/Prelude.hs +++ b/src/Discord/Internal/Types/Prelude.hs @@ -11,9 +11,11 @@ import Data.Word import Data.Aeson.Types +import qualified Data.ByteString as B import Data.Time.Clock import qualified Data.Text as T import Data.Time.Clock.POSIX +import Web.Internal.HttpApiData import Data.Bifunctor (first) import Text.Read (readMaybe) @@ -53,6 +55,9 @@ (Just i) -> pure i ) +instance ToHttpApiData Snowflake where + toUrlPiece = T.pack . show + newtype DiscordId a = DiscordId { unId :: Snowflake } deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) @@ -68,6 +73,9 @@ instance FromJSON (DiscordId a) where parseJSON = fmap DiscordId . parseJSON +instance ToHttpApiData (DiscordId a) where + toUrlPiece = T.pack . show + data ChannelIdType type ChannelId = DiscordId ChannelIdType @@ -92,9 +100,6 @@ data UserIdType type UserId = DiscordId UserIdType -data OverwriteIdType -type OverwriteId = DiscordId OverwriteIdType - data RoleIdType type RoleId = DiscordId RoleIdType @@ -122,15 +127,28 @@ data ScheduledEventEntityIdType type ScheduledEventEntityId = DiscordId ScheduledEventEntityIdType -newtype InteractionToken = InteractionToken T.Text - deriving (Show, Read, Eq, Ord) +newtype DiscordToken a = DiscordToken { unToken :: T.Text } + deriving (Ord, Eq) -instance ToJSON InteractionToken where - toJSON (InteractionToken token) = String token +instance Show (DiscordToken a) where + show = show . unToken -instance FromJSON InteractionToken where - parseJSON = withText "InteractionToken" (pure . InteractionToken) +instance Read (DiscordToken a) where + readsPrec p = fmap (first DiscordToken) . readsPrec p +instance ToJSON (DiscordToken a) where + toJSON = toJSON . unToken + +instance FromJSON (DiscordToken a) where + parseJSON = fmap DiscordToken . parseJSON + +instance ToHttpApiData (DiscordToken a) where + toUrlPiece = unToken + +type InteractionToken = DiscordToken InteractionIdType + +type WebhookToken = DiscordToken WebhookIdType + type Shard = (Int, Int) -- | Gets a creation date from a snowflake. @@ -181,3 +199,43 @@ toMaybeJSON :: (ToJSON a) => a -> Maybe Value toMaybeJSON = return . toJSON + + +-- | @Base64Image mime data@ represents the base64 encoding of an image (as +-- @data@), together with a tag of its mime type (@mime@). The constructor is +-- only for Internal use, and its public export is hidden in Discord.Types. +-- +-- Public creation of this datatype should be done using the relevant smart +-- constructors for Emoji, Sticker, or Avatar. +data Base64Image a = Base64Image T.Text T.Text + deriving (Show, Read, Eq, Ord) + +-- | The ToJSON instance for Base64Image creates a string representation of the +-- image's base-64 data, suited for using as JSON values. +-- +-- The format is: @data:%MIME%;base64,%DATA%@. +instance ToJSON (Base64Image a) where + toJSON (Base64Image mime im) = String $ "data:" <> mime <> ";base64," <> im + +-- | @getMimeType bs@ returns a possible mimetype for the given bytestring, +-- based on the first few magic bytes. It may return any of PNG/JPEG/GIF or WEBP +-- mimetypes, or Nothing if none are matched. +-- +-- Reference: https://en.wikipedia.org/wiki/List_of_file_signatures +-- +-- Although Discord's official documentation does not state WEBP as a supported +-- format, it has been accepted for both emojis and user avatars no problem +-- when tested manually. +-- +-- /Inspired by discord.py's implementation./ +getMimeType :: B.ByteString -> Maybe T.Text +getMimeType bs + | B.take 8 bs == "\x89\x50\x4E\x47\x0D\x0A\x1A\x0A" + = Just "image/png" + | B.take 3 bs == "\xff\xd8\xff" || B.take 4 (B.drop 6 bs) `elem` ["JFIF", "Exif"] + = Just "image/jpeg" + | B.take 6 bs == "\x47\x49\x46\x38\x37\x61" || B.take 6 bs == "\x47\x49\x46\x38\x39\x61" + = Just "image/gif" + | B.take 4 bs == "RIFF" && B.take 4 (B.drop 8 bs) == "WEBP" + = Just "image/webp" + | otherwise = Nothing diff --git a/src/Discord/Internal/Types/User.hs b/src/Discord/Internal/Types/User.hs --- a/src/Discord/Internal/Types/User.hs +++ b/src/Discord/Internal/Types/User.hs @@ -73,7 +73,7 @@ -- TODO: fully update webhook structure data Webhook = Webhook { webhookId :: WebhookId - , webhookToken :: Maybe Text + , webhookToken :: Maybe WebhookToken , webhookChannelId :: ChannelId } deriving (Show, Read, Eq, Ord) @@ -83,16 +83,17 @@ <*> o .:? "token" <*> o .: "channel_id" +-- | The connection object that the user has attached. data ConnectionObject = ConnectionObject - { connectionObjectId :: Text - , connectionObjectName :: Text - , connectionObjectType :: Text - , connectionObjectRevoked :: Bool - , connectionObjectIntegrations :: [IntegrationId] - , connectionObjectVerified :: Bool - , connectionObjectFriendSyncOn :: Bool - , connectionObjectShownInPresenceUpdates :: Bool - , connectionObjectVisibleToOthers :: Bool + { connectionObjectId :: Text -- ^ id of the connection account + , connectionObjectName :: Text -- ^ the username of the connection account + , connectionObjectType :: Text -- ^ the service of the connection (twitch, youtube) + , connectionObjectRevoked :: Bool -- ^ whether the connection is revoked + , connectionObjectIntegrations :: [IntegrationId] -- ^ List of server `IntegrationId` + , connectionObjectVerified :: Bool -- ^ whether the connection is verified + , connectionObjectFriendSyncOn :: Bool -- ^ whether friend sync is enabled for this connection + , connectionObjectShownInPresenceUpdates :: Bool -- ^ whether activities related to this connection will be shown in presence updates + , connectionObjectVisibleToOthers :: Bool -- ^ visibility of this connection } deriving (Show, Read, Eq, Ord) instance FromJSON ConnectionObject where diff --git a/src/Discord/Types.hs b/src/Discord/Types.hs --- a/src/Discord/Types.hs +++ b/src/Discord/Types.hs @@ -8,6 +8,7 @@ , GatewayReceivable(..) , EventInternalParse(..) , InternalDiscordEnum(..) + , Base64Image(..) , colorToInternal , convertToRGB