diff options
| author | LLLL Colonq <llll@colonq> | 2023-11-16 19:06:43 -0500 |
|---|---|---|
| committer | LLLL Colonq <llll@colonq> | 2023-11-16 19:06:43 -0500 |
| commit | dcef0b65069fb38fd0f6c4382353167f603ebff1 (patch) | |
| tree | 45954ffe308c3dd056e6af4f734e6d2af89e5856 | |
Initial commit
132 files changed, 15879 insertions, 0 deletions
@@ -0,0 +1 @@ +use flake diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..de8e882 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.direnv +dist-newstyle +fig-monitor-*.toml
\ No newline at end of file diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..03dbf5a --- /dev/null +++ b/cabal.project @@ -0,0 +1,10 @@ +packages: + fig-utils/ + fig-bus/ + fig-monitor-twitch/ + fig-monitor-discord/ + fig-monitor-irc/ + fig-monitor-bullfrog/ + fig-bridge-irc-discord/ + deps/irc-client/ + deps/irc-conduit/
\ No newline at end of file diff --git a/cabal.project.local b/cabal.project.local new file mode 100644 index 0000000..a558e04 --- /dev/null +++ b/cabal.project.local @@ -0,0 +1 @@ +ignore-project: False diff --git a/deps/discord-haskell/.github/workflows/main.yml b/deps/discord-haskell/.github/workflows/main.yml new file mode 100644 index 0000000..aec9070 --- /dev/null +++ b/deps/discord-haskell/.github/workflows/main.yml @@ -0,0 +1,91 @@ +name: CI + +# when the workflow will run +on: + push: + branches: [ master ] + pull_request: + + # Allows manually starting this workflow from the Actions tab + workflow_dispatch: + +jobs: + # To dynamically create a build matrix, we generate a JSON output from one job + # and use fromJson in the next job to construct the matrix. + # This dynamic approach means we don't have to update the CI file when we + # change supported GHC versions. + generate-matrix: + name: Generate GHC build matrix + runs-on: ubuntu-latest + outputs: + ghc-matrix: ${{ steps.set-ghc-matrix.outputs.versions }} + steps: + - uses: actions/checkout@v2 + + - name: Parse the cabal tested-with stanza + id: parse + run: | + echo "::set-output name=tested-with-versions::$(runghc .github/workflows/parseVersions.hs)" + + - name: Set the GHC matrix for the next job + id: set-ghc-matrix + # We use single quotes here, since the output from the previous step + # will not have escaped double quotes, and it's just easier to use single + # quotes on the outside than try to escape the inner double quotes. + run: echo '::set-output name=versions::{"ghc-version":${{ steps.parse.outputs.tested-with-versions }}}' + + build: + name: Build Check + needs: generate-matrix + runs-on: ubuntu-latest + strategy: + # Whether to stop other jobs in the matrix if one fails. This is undesirable + # since we want to check e.g. it compiles on 8.10.7 regardless of the status + # of 9.X. + fail-fast: false + # Feed the json from the previous job. + matrix: ${{ fromJson(needs.generate-matrix.outputs.ghc-matrix) }} + steps: + - uses: actions/checkout@v2 + + - uses: haskell/actions/setup@v2 + id: setup-haskell + with: + # We install a global GHC and use Stack with --system-ghc + ghc-version: ${{ matrix.ghc-version }} + enable-stack: true + + # First run cabal, since it is generally quicker + - name: "Cabal: Update cabal package database, generate build plan" + run: | + cabal update + cabal build --dry-run + + - name: "Cabal: Cache Dependencies" + id: cache + uses: actions/cache@v2 + with: + # Include the build plan file generated by cabal configure, but allow + # restoring without its hash as long as the GHC version is the same. + key: cabal-${{ runner.os }}-${{ matrix.ghc-version }}-${{ hashFiles('**/plan.json') }} + restore-keys: | + cabal-${{ runner.os }}-${{ matrix.ghc-version }} + path: | + ${{ steps.setup-haskell.outputs.cabal-store }} + dist-newstyle + + - name: "Cabal: Build" + run: cabal build + + # Now run stack + - name: "Stack: Cache ~/.stack" + id: cache-stack + uses: actions/cache@v2 + with: + path: ~/.stack + key: stack-${{ runner.os }}-${{ matrix.ghc-version }}-${{ hashFiles('stack.yaml') }} + restore-keys: | + stack-${{ runner.os }}-${{ matrix.ghc-version }} + + - name: "Stack: Build" + run: stack build --system-ghc diff --git a/deps/discord-haskell/.github/workflows/parseVersions.hs b/deps/discord-haskell/.github/workflows/parseVersions.hs new file mode 100644 index 0000000..3302f17 --- /dev/null +++ b/deps/discord-haskell/.github/workflows/parseVersions.hs @@ -0,0 +1,34 @@ +-- Small script to use the Cabal library to parse the Tested-With stanza +-- from discord-haskell.cabal, and output to stdout in a JSON friendly list. +module Main where + +import Prelude hiding (readFile) +import Data.ByteString (readFile) +import Data.List (intersperse) +import Data.Maybe (maybeToList) +import Distribution.Compiler (CompilerFlavor(GHC)) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Distribution.Pretty (pretty) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription(packageDescription)) +import Distribution.Types.PackageDescription (PackageDescription(testedWith)) +import Distribution.Types.Version (versionNumbers) +import Distribution.Types.VersionRange.Internal (VersionRange(ThisVersion)) +import Text.PrettyPrint (render, brackets, comma, doubleQuotes) + +main = do + bs <- readFile "discord-haskell.cabal" + let mbVersions = testedWith . packageDescription <$> parseGenericPackageDescriptionMaybe bs + -- e.g. mbVersions = Just [(GHC,ThisVersion (mkVersion [8,10,7])),(GHC,ThisVersion (mkVersion [9,2])),(GHC,ThisVersion (mkVersion [9,4,1]))] + let versions = concat $ maybeToList mbVersions + -- e.g. versions = [(GHC,ThisVersion (mkVersion [8,10,7])),(GHC,ThisVersion (mkVersion [9,2])),(GHC,ThisVersion (mkVersion [9,4,1]))] + let ghcVersions = + [ ghcVersion + | (flavor, versionRange) <- versions + -- Filter only GHC + , GHC == flavor + -- Filter only to exact matches: "== VERSION" + , let (ThisVersion ghcVersion) = versionRange + ] + -- e.g. ghcVersions = [mkVersion [8,10,7],mkVersion [9,2],mkVersion [9,4,1]] + let prettyVersions = brackets $ mconcat $ intersperse comma $ map (doubleQuotes . pretty) ghcVersions + putStrLn $ render prettyVersions diff --git a/deps/discord-haskell/.gitignore b/deps/discord-haskell/.gitignore new file mode 100644 index 0000000..90daa99 --- /dev/null +++ b/deps/discord-haskell/.gitignore @@ -0,0 +1,21 @@ +# As a library I won't commit the lock file +stack.yaml.lock + +.cabal-sandbox/* +.stack-work +.stack/* +**/.stack/* +**/.stack-work/* +cabal.sandbox.config +shell.nix +_cache +_site +*.hi +*.o + +cachedState +the-log-of-discord-haskell.txt +examples/*.secret +upload-haddock.sh +dist* + diff --git a/deps/discord-haskell/LICENSE b/deps/discord-haskell/LICENSE new file mode 100644 index 0000000..56d616c --- /dev/null +++ b/deps/discord-haskell/LICENSE @@ -0,0 +1,26 @@ +MIT License + +Copyright (c) Joshua Koike, 2019 karl + +Copyright for portions of project discord-haskell are held by +Joshua Koike,2016 as part of project discord-hs. All other copyright +for project discord-haskell are held by karl,2019. + + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/deps/discord-haskell/README.md b/deps/discord-haskell/README.md new file mode 100644 index 0000000..e9a50d9 --- /dev/null +++ b/deps/discord-haskell/README.md @@ -0,0 +1,75 @@ +# discord-haskell [](https://github.com/discord-haskell/discord-haskell/actions/) [](https://hackage.haskell.org/package/discord-haskell) [](https://discord.gg/eaRAGgX3bK) + + +Build that discord bot in Haskell! Also checkout the +[calamity haskell library](https://github.com/nitros12/calamity) +for a more advanced interface. + + +#### Documentation + +#### [[installing](./docs/installing.md)] [[debugging](./docs/debugging.md)] [[creating-bot](./docs/creating-bot.md)] + +#### [[app-commands](./docs/applicationcommands.md)] [[components](./docs/components.md)] [[cache](./docs/cache.md)] [[embeds](./docs/embeds.md)] [[emoji](./docs/emoji.md)] [[intents](./docs/intents.md)] [[voice](./docs/voice.md)] + +#### [[design](./docs/design.md)] [[contributing](./docs/contributing.md)] [[todo](./docs/todo.md)] + +#### Example + +This is an example bot that replies "pong" to messages that start with "ping". Checkout the [other examples](./examples/) for things like state management. + +```haskell +{-# LANGUAGE OverloadedStrings #-} -- allows "string literals" to be Text +import Control.Monad (when, void) +import UnliftIO.Concurrent +import Data.Text (isPrefixOf, toLower, Text) +import qualified Data.Text.IO as TIO + +import Discord +import Discord.Types +import qualified Discord.Requests as R + +-- | Replies "pong" to every message that starts with "ping" +pingpongExample :: IO () +pingpongExample = do + userFacingError <- runDiscord $ def + { discordToken = "Bot ZZZZZZZZZZZZZZZZZZZ" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + } -- if you see OnLog error, post in the discord / open an issue + + TIO.putStrLn userFacingError + -- userFacingError is an unrecoverable error + -- put normal 'cleanup' code in discordOnEnd (see examples) + +eventHandler :: Event -> DiscordHandler () +eventHandler event = case event of + MessageCreate m -> when (isPing m && not (fromBot m)) $ do + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") + threadDelay (2 * 10^6) + void $ restCall (R.CreateMessage (messageChannelId m) "Pong!") + _ -> return () + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `isPrefixOf`) . toLower . messageContent +``` + +#### Discord Server + +Ask questions, get updates, request features, etc in the project discord server: <https://discord.gg/eaRAGgX3bK> + +#### Official Discord Documentation + +This api closley matches the [official discord documentation](https://discord.com/developers/docs/intro), +which lists the rest requests, gateway events, and gateway sendables. + +You can use the docs to check the name of something you want to do. For example: +the docs list a [Get Channel](https://discord.com/developers/docs/resources/channel#get-channel) API path, +which translates to discord-haskell's rest request ADT for `GetChannel` of type `ChannelId -> ChannelRequest Channel`. + +#### Open an Issue + +If something goes wrong: check the error message (optional: check [the debugging logs](./docs/debugging.md)), make sure you have the most recent version, ask on discord, or open a github issue. diff --git a/deps/discord-haskell/changelog.md b/deps/discord-haskell/changelog.md new file mode 100644 index 0000000..371ea02 --- /dev/null +++ b/deps/discord-haskell/changelog.md @@ -0,0 +1,337 @@ +# Changelog + +View on GitHub for the newest ChangeLog: https://github.com/discord-haskell/discord-haskell/blob/master/changelog.md + +The Discord API constantly changes. This library issues updates when we implement new features added to the API or remove outdated functionalities. In order to interact with the Discord API safely and predictably, please update the library whenever there is a new version released. + +## Unreleased + +- + +## 1.15.4 + +- [matobet](https://github.com/discord-haskell/discord-haskell/pull/148) Adding GHC 9.2.* support + +- [aquarial](https://github.com/discord-haskell/discord-haskell/pull/149) Slash command validation extends to numbers + +- [0x3alex](https://github.com/discord-haskell/discord-haskell/pull/152) Permissions bit flags + +- [yutotakano](https://github.com/discord-haskell/discord-haskell/pull/153) Extending CI testing + +- [1Computer1](https://github.com/discord-haskell/discord-haskell/pull/154) Exporting some internal types + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/155) Select menu additions + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/158) Caching more information + +- [tam-carre](https://github.com/discord-haskell/discord-haskell/pull/159) New example for interactions + +- [XanderDJ](https://github.com/discord-haskell/discord-haskell/pull/164) New role permissions setup + +- [chuahao](https://github.com/discord-haskell/discord-haskell/pull/168) Fixing parsing of permissions + +- [chuahao](https://github.com/discord-haskell/discord-haskell/pull/169) Adding role icon to `ModifyGuildRoleOpts` + +- [chuahao](https://github.com/discord-haskell/discord-haskell/pull/170) Add utilities to measure the latency to discord + +## 1.15.3 + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/145) Fixing behind the scenes for hackage + +## 1.15.2 + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/143) Adding some utility and fixing some versions in place + +## 1.15.1 + +- [Geometer1729](https://github.com/discord-haskell/discord-haskell/pull/141) Fixing a bug in localization code + +## 1.15.0 + +- [Annwan](https://github.com/discord-haskell/discord-haskell/pull/137) Implemented optional localization for application commands. `[..]LocalizedName` and `[..]LocalizedDescription` fields have been added to many ADTs ([Discord documentation](https://discord.com/developers/docs/interactions/application-commands#localization)) + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/136) Removed `applicationCommandDefaultPermission` from `ApplicationCommand`, replaced it with `applicationCommandDefaultMemberPermissions` and `applicationCommandDMPermission` ([Discord changelog](https://discord.com/developers/docs/change-log#updated-command-permissions)) + +- [yutotakano](https://github.com/discord-haskell/discord-haskell/pull/135) Implemented session-specific Resume URLs for the Gateway internally, which will prevent disconnects in the future ([Discord changelog](https://discord.com/developers/docs/change-log#sessionspecific-gateway-resume-urls)). Also removed the deprecated list of private channels received in Ready event. + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/133) Implemented maximum and minimum string lengths for application command options ([Discord changelog](https://discord.com/developers/docs/change-log#min-and-max-length-for-command-options)). Also implemented calculated context permissions for interaction payloads ([Discord changelog](https://discord.com/developers/docs/change-log#calculated-permissions-in-interaction-payloads)) + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/132) Simplified internals of JSON creation using `objectFromMaybes` and `.=?`. Support `aeson-2.0` + +- [yutotakano](https://github.com/discord-haskell/discord-haskell/pull/134) Loosened some acceptable version bounds for `http-client`, `req` and `http-api-data`, that were added with 1.14.0 + +## 1.14.0 + +- [degustaf](https://github.com/discord-haskell/discord-haskell/pull/131) Add `Exception` instance for `RestCallErrorCode` + +- [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/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/discord-haskell/discord-haskell/pull/116) Typesafe Snowflakes (guildid, channelid, userid, etcid) + +- Improve `restCall` type error messages https://github.com/discord-haskell/discord-haskell/issues/102 + +## 1.12.5 + +- [Annwan](https://github.com/discord-haskell/discord-haskell/pull/109) Add `ScheduledEvent` rest API + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/110) Add stickers API + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/111) Add ModifyGuildMember 'timeout' option + +## 1.12.4 + +- Library won't crash if something fails to parse. Errors are printed to the log + +## 1.12.3 + +- Add another CreateMessage flag option, stop crashing on unknown flags. + +## 1.12.2 + +- [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/discord-haskell/discord-haskell/pull/103) Add threads, switch api to V10, Update Guild data fields + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/104) Add model interaction and components + +## 1.12.0 + +- [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/discord-haskell/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/94) fixed a parse error with webhooktoken + +- Rename fields `messageText` -> `messageContent`, `messageChannel` -> `messageChannelId` + +## 1.10.0 + +- [drewolson](https://github.com/discord-haskell/discord-haskell/pull/80) allows parsing an optional guild region + +- [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. + +- Added `Read` instance to complement `Show` for lots of types. Removed ToJSON for `Channel`. + +## 1.9.1 + +- Add [color attribute for CreateEmbed](https://github.com/discord-haskell/discord-haskell/issues/78) + +- 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/discord-haskell/discord-haskell/issues/77) + +- 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/discord-haskell/discord-haskell/issues/69) + +## 1.8.7 + +- 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/discord-haskell/discord-haskell/issues/67) to ChannelGuildCategory + +## 1.8.5 + +- Fix examples/ping-pong.hs compilation error https://github.com/discord-haskell/discord-haskell/issues/65 + +## 1.8.4 + +- [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/discord-haskell/discord-haskell/issues/62 + +## 1.8.2 + +- Added 'Competing' activity https://github.com/discord-haskell/discord-haskell/issues/61 + +- 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/discord-haskell/discord-haskell/issues/56 + +## 1.8.0 + +- Fixed [null parent_id on channel](https://github.com/discord-haskell/discord-haskell/issues/55) + +## 1.7.0 + +- [elikoga](https://github.com/discord-haskell/discord-haskell/pull/51) Changed to use `ReaderT` interface + +- [elikoga](https://github.com/discord-haskell/discord-haskell/pull/50) Fixed compiler warnings + +- Changed api url to new `discord.com` + +## 1.6.1 + +- Changed discordapp.com to discord.com in accordance with official discord policy + +- [rexim](https://github.com/discord-haskell/discord-haskell/pull/41) Add `Emoji.user` field. Who uploaded the emoji + +## 1.6.0 + +- Add News Channel and StorePage Channel. Fix crash `Unknown channel type:5` + +- Add NSFW and UserRateLimit to `Channel` type + +## 1.5.1 + +- Fix `EditMessage` rest request, send JSON + +## 1.5.0 + +- [rexim](https://github.com/discord-haskell/discord-haskell/pull/35) Add `Read` instance for `Snowflake` + +## 1.4.0 + +- Rename `SubEmbed` to `EmbedPart` + +- New and improved Embed API: Add `CreateEmbed` record and `createEmbed :: CreateEmbed -> Embed` + +- `CreateEmbedImageUpload` implementation inspired by [Flutterlice](https://github.com/discord-haskell/discord-haskell/pull/32) + +## 1.3.0 + +- [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 + +- Rename `Ban` to `GuildBan` + +- Re-export UTCTime from `time` package + +## 1.2.0 + +- [MDeltaX](https://github.com/discord-haskell/discord-haskell/pull/27) Fixed typo: depreciated --> deprecated + +- [MDeltaX](https://github.com/discord-haskell/discord-haskell/pull/29) More consistency: RoleID --> RoleId + +- [MDeltaX](https://github.com/discord-haskell/discord-haskell/pull/29) Fix ModifyGuildRole: Post --> Patch && optional args + +- [Hippu](https://github.com/discord-haskell/discord-haskell/pull/31) Won't crash on integer-nonces in ChannelMessage-events (usually strings) + +## 1.1.3 + +- Minor improvements to rate-limiting like using newer `X-RateLimit-Reset-After` header + +## 1.1.2 + +- [michalrus](https://github.com/discord-haskell/discord-haskell/issues/25) Fix `DeleteGuildRole` parse exception + +## 1.1.1 + +- Fix ModifyGuildRolePositions results in 400 Bad Request issue + +## 1.1.0 + +- Upgrade req to 2.x major version. + +## 1.0.0 + +- Going through some major updates to the library. Expect types to change and things to break. + +- 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/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 + +## 0.8.3 + +- Simplify Message Author from `Either WebhookId User` to `User` + +- Add `loginRestGatewayWithLog` + +### 0.8.2 + +- Hardcode CreateReaction delay so bots can add reactions 4 times faster + +- [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/discord-haskell/discord-haskell/pull/11) Fixed parse error on GuildRoleDelete: role_id instead of role + +### 0.8.0 + +- `MessageUpdate` does not contain a full Message object, just `ChannelId` `MessageId` + +- Message Author changed from `User` to `Either WebhookId User` + +- Add Webhook ADT + +- Add requests: GetInvite, DeleteInvite + +- UpdateStatusVoiceOpts takes Bool for Mute + +- `Unavailable` becomes `GuildUnavailable` + +### 0.7.1 + +- [t1m0thyj](https://github.com/discord-haskell/discord-haskell/pull/6/files) Typo in RequestGuildMemberOpts fields fixed. + +- [t1m0thyj](https://github.com/discord-haskell/discord-haskell/pull/6/files) Added Activity, ActivityType ADT + +- UpdateStatusTypes became UpdateStatusType (singular ADT) + +- [t1m0thyj](https://github.com/discord-haskell/discord-haskell/pull/7) Retry connection on 1001 websocket close + +### 0.7.0 + +- Snowflake -> named id + +- Add requests: ModifyChanPositions, CreateGuildChannel + +- Changed constructors of Channel to have prefix "Channel", isGuildChannel --> channelIsInGuild + +- Change Emoji Id ADTs + +### 0.6.0 + +- Add requests: CreateGuildEmoji, GroupDMRemoveRecipient, ModifyCurrentUser, EditChannelPermissions, CreateChannelInvite, GroupDMAddRecipient, ModifyGuild + +- restCall, readCache pass errors as an ADT, including underling http exceptions + +- Only add "Bot " prefix to secret token if it's not there + +### 0.5.1 + +- sendCommand with GatewaySendable types + +### 0.5.0 + +- restCall with Request types + +- nextEvent with Event types diff --git a/deps/discord-haskell/discord-haskell.cabal b/deps/discord-haskell/discord-haskell.cabal new file mode 100644 index 0000000..08faa6b --- /dev/null +++ b/deps/discord-haskell/discord-haskell.cabal @@ -0,0 +1,184 @@ +cabal-version: 2.0 +name: discord-haskell +version: 1.15.4 +description: Functions and data types to write discord bots. + Official discord docs <https://discord.com/developers/docs/reference>. + . + See the project readme for quickstart notes + <https://github.com/discord-haskell/discord-haskell#discord-haskell-> +synopsis: Write bots for Discord in Haskell +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 +maintainer: ksfish5@gmail.com +copyright: 2019 Karl +category: Network +build-type: Simple +tested-with: GHC == 8.10.7 + , GHC == 9.2 + , GHC == 9.4 +extra-doc-files: README.md + , changelog.md + +source-repository head + type: git + location: https://github.com/discord-haskell/discord-haskell.git + +executable ping-pong + main-is: ping-pong.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable interaction-commands + main-is: interaction-commands.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + , bytestring + +executable interaction-commands-simple + main-is: interaction-commands-simple.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable cache + main-is: cache.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable gateway + main-is: gateway.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable rest-without-gateway + main-is: rest-without-gateway.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable state-counter + main-is: state-counter.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +library + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards + hs-source-dirs: src + default-language: Haskell2010 + other-modules: + Paths_discord_haskell + autogen-modules: + Paths_discord_haskell + 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.Rest.ScheduledEvents + , 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.RolePermissions + , Discord.Internal.Types.ScheduledEvents + build-depends: + -- https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/libraries/version-history + -- below also sets the GHC version effectively. set to == 8.10.*, == 9.0.*., == 9.2.*, == 9.4.* + base == 4.14.* || == 4.15.* || == 4.16.* || == 4.17.*, + aeson >= 1.5 && < 1.6 || >= 2.0 && < 2.2, + async >=2.2 && <2.3, + bytestring >=0.10 && <0.12, + base64-bytestring >=1.1 && <1.3, + containers >=0.6 && <0.7, + data-default >=0.7 && <0.8, + emoji ==0.1.*, + http-client >=0.6 && <0.8, + iso8601-time >=0.1 && <0.2, + MonadRandom >=0.5 && <0.6, + req >=3.9 && <3.14, + safe-exceptions >=0.1 && <0.2, + text >=1.2 && <3, + time, + websockets >=0.12 && <0.13, + network >=3.0.0.0 && <3.2.0.0, + wuss >=1.1 && <3, + mtl >=2.2 && <2.3, + unliftio >=0.2 && <0.3, + scientific >=0.3 && <0.4, + http-api-data >=0.4 && <0.6, + unordered-containers >=0.2.10.0 && <0.3 diff --git a/deps/discord-haskell/docs/applicationcommands.md b/deps/discord-haskell/docs/applicationcommands.md new file mode 100644 index 0000000..f27e412 --- /dev/null +++ b/deps/discord-haskell/docs/applicationcommands.md @@ -0,0 +1,18 @@ +### Application Commands + +https://discord.com/developers/docs/interactions/application-commands + +There are three steps to application commands. + +1. Register the command with discord. This only needs to be done once, but there is no harm in doing it again/on each reboot, as the creation of commands just overwrites other commands of the same type and name. + 1. This is achieved by sending a `CreateGuildApplicationCommand` event to discord. The easiest way to do this is by capturing and working off of the `Ready` event in the event loop, which is only sent in the initial startup. + 2. Commands can either be global (in which case there is a delay to their addition) or they can be guild (server) specific. + 3. There are other application command requests that can be conducted in this step, so please have a look at the documentation. + 4. Finally, the application id (which is needed to create commands) of the bot is stored in the cache if you need to create, edit, delete, or get application commands later in the program. +2. Receive an interaction + 1. This is achieved by capturing the `Interaction` event in the event loop +3. Respond to the interaction + 1. When you have captured an interaction, you can act on the information within, and send a reply using the appropriate method, creating an `InteractionResponse` and sending that with `CreateInteractionResponse`. + +Now you're ready to create application commands! If you have any questions, please investigate the source and docs first, and then join the discord server and ask questions there. + diff --git a/deps/discord-haskell/docs/cache.md b/deps/discord-haskell/docs/cache.md new file mode 100644 index 0000000..c3f91b5 --- /dev/null +++ b/deps/discord-haskell/docs/cache.md @@ -0,0 +1,7 @@ +### Cache + +The cache (`readCache`) is currently deprecated. + +It's capable of working, but the code to update is not written. + +Current source code is at [Discord.Internal.Gateway.Cache](../src/Discord/Internal/Gateway/Cache.hs) diff --git a/deps/discord-haskell/docs/components.md b/deps/discord-haskell/docs/components.md new file mode 100644 index 0000000..32d3f6e --- /dev/null +++ b/deps/discord-haskell/docs/components.md @@ -0,0 +1,6 @@ + +### Components + +TODO + +https://discord.com/developers/docs/interactions/message-components diff --git a/deps/discord-haskell/docs/contributing.md b/deps/discord-haskell/docs/contributing.md new file mode 100644 index 0000000..56da78f --- /dev/null +++ b/deps/discord-haskell/docs/contributing.md @@ -0,0 +1,17 @@ + +### Contributing + +The library tries to hide as much detail from the user as reasonable. Lean towards making the library code uglier than the user code. The library does not meet this standard yet, but ideals make hypocrits of us all. + +A user should not have to import anything from `Discord.Internal.*` (although they can futz with the internals if they want to) + +#### Formatting + +Some of the code is moldy, and some is merely old. + +The library is somewhat open to code format style. +Try to match the formatting of the code around you. +Planning to use ormolu to autoformat the sourcecode eventually +(see [the formatting tracking issue](https://github.com/aquarial/discord-haskell/issues/87)) + +When in doubt make it look nice. diff --git a/deps/discord-haskell/docs/creating-bot.md b/deps/discord-haskell/docs/creating-bot.md new file mode 100644 index 0000000..93f47ce --- /dev/null +++ b/deps/discord-haskell/docs/creating-bot.md @@ -0,0 +1,13 @@ +1. Create an application at the Developer Portal https://discordapp.com/developers/applications + +2. Add a 'Bot User' using the settings pane on the left. Take note of `CLIENT ID` on this page. + +3. Use the BOT PERMISSIONS tab to compute a Permissions Int + +4. Invite the bot to a server filling in the `<information>` below. + +Client ID and Permissions come from previous steps. + +`https://discordapp.com/oauth2/authorize?client_id=<CLIENT_ID>&scope=bot&permissions=<PERMISSIONS>` + +5. You are ready to run the examples diff --git a/deps/discord-haskell/docs/debugging.md b/deps/discord-haskell/docs/debugging.md new file mode 100644 index 0000000..5576a55 --- /dev/null +++ b/deps/discord-haskell/docs/debugging.md @@ -0,0 +1,29 @@ + +### Debugging + + +```haskell +example :: IO () +example = do userFacingError <- runDiscord $ def + { discordToken = "Bot ZZZZZZZZZZZZZZZZZZZ" + + -- discordOnLog :: T.Text -> IO () + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + } + + -- userFacingError :: T.Text + TIO.putStrLn userFacingError + +``` + + +1. Always print the `userFacingError` Text returned from `runDiscord`. This is used for errors that cannot be recovered from. + +2. Use the `discordOnLog` handler to print debugging information as it happens. + + +If something else goes wrong with the library please open an issue. It is helpful, +but not always necessary, to attach a log. + +Assign a handler to the `discordOnLog :: Text -> IO ()` to print info as it happens. +Remember to remove sensitive information before posting. diff --git a/deps/discord-haskell/docs/design.md b/deps/discord-haskell/docs/design.md new file mode 100644 index 0000000..a642b93 --- /dev/null +++ b/deps/discord-haskell/docs/design.md @@ -0,0 +1,51 @@ +### Design + +```haskell +~> :info runDiscord +runDiscord :: RunDiscordOpts -> IO T.Text {- Text is user facing error. Print it -} + +~> :info RunDiscordOpts +data RunDiscordOpts = RunDiscordOpts + { discordToken :: T.Text + , discordOnStart :: DiscordHandler () + , discordOnEnd :: IO () + , discordOnEvent :: Event -> DiscordHandler () -- response to action + , discordOnLog :: Text -> IO () + , discordForkThreadForEvents :: Bool + } + +~> :info DiscordHandler +type DiscordHandler = ReaderT DiscordHandle IO + +{- ReaderT for access to the Handle -} + +{- Event handlers and Options for the program + + An exception in discordOnStart exits the program immediately + An exception in discordOnEvent continues loop + +-} + + ~> :info DiscordHandle +data DiscordHandle = DiscordHandle + { --[[ Some internal data that you normally won't use ]] + --[[ Makes sure we don't violate rate-limits! ]] + --[[ Threadsafe access ]] + } + +{- Import Discord.Handle to view the insides -} + +``` + + +#### Internals + +Use `Chan`s to pass data between threads. + +#### Websocket loop + +Make user handle events as they happen + +#### Rest request loop + +Allow executing rest requests without overstepping ratelimits diff --git a/deps/discord-haskell/docs/embeds.md b/deps/discord-haskell/docs/embeds.md new file mode 100644 index 0000000..eec38d9 --- /dev/null +++ b/deps/discord-haskell/docs/embeds.md @@ -0,0 +1,21 @@ + +### Embeds + +Embeds are special messages with boarders and images. [Example embed created by discord-haskell](./examples/embed-photo.jpg) + +The `Embed` record (and sub-records) store embed data received from Discord. + +The `CreateEmbed` record stores data when we want to create an embed. + +`CreateEmbed` has a `Default` instance, so you only need to specify the fields you use: + +```haskell +_ <- restCall (R.CreateMessageEmbed <channel_id> "Pong!" $ + def { createEmbedTitle = "Pong Embed" + , createEmbedImage = Just $ CreateEmbedImageUpload <bytestring> + , createEmbedThumbnail = Just $ CreateEmbedImageUrl + "https://avatars2.githubusercontent.com/u/37496339" + }) +``` + +Uploading a file each time is slow, prefer uploading images to a hosting site like imgur.com, and then referencing them. diff --git a/deps/discord-haskell/docs/emoji.md b/deps/discord-haskell/docs/emoji.md new file mode 100644 index 0000000..ce3d3a9 --- /dev/null +++ b/deps/discord-haskell/docs/emoji.md @@ -0,0 +1,13 @@ + +### Emoji + +For single character Emoji you can use the unicode name ("eyes", "fire", etc). + +For multi-character Emoji you must use the discord format. Type `\:emoji:` into +a discord chat and paste that into the Text + +For example `:thumbsup::skin-tone-3:` is `"👍\127997"`. +A custom emoji will look like `<name:id_number>` or `name:id_number`. + +See [examples/ping-pong.hs](https://github.com/discord-haskell/discord-haskell/blob/master/examples/ping-pong.hs) + for a `CreateReaction` request in use. diff --git a/deps/discord-haskell/docs/installing.md b/deps/discord-haskell/docs/installing.md new file mode 100644 index 0000000..9ded477 --- /dev/null +++ b/deps/discord-haskell/docs/installing.md @@ -0,0 +1,97 @@ +### Installing + +discord-haskell is on hosted on hackage at <https://hackage.haskell.org/package/discord-haskell>, + +use the latest the HACKAGE_VERSION from the changelog +<https://github.com/discord-haskell/discord-haskell/blob/master/changelog.md> + + +#### Stack - Hackage (recommended) + +In `stack.yaml` + +```yaml +extra-deps: +- emoji-0.1.0.2 +- discord-haskell-HACKAGE_VERSION +``` + +In `project.cabal` + +```cabal +executable haskell-bot + main-is: src/Main.hs + default-language: Haskell2010 + ghc-options: -threaded + build-depends: base + , text + , discord-haskell +``` + + + + + + +#### Cabal - Hackage + +In `project.cabal` + +```cabal +cabal-version: 2.0 +name: haskell-bot +version: 0.0.1 +build-type: Simple + +executable haskell-bot + main-is: src/Main.hs + default-language: Haskell2010 + ghc-options: -threaded + build-depends: base + , text + , discord-haskell == HACKAGE_VERSION + -- check hackage for most recent available version: + -- https://hackage.haskell.org/package/discord-haskell +``` + + + + + + +#### Stack - GitHub + +For specific/alternate versions not released on hackage. Only recommended if you're trying out a fork, or trying out a newer version. + +## Stack - GitHub + +In `stack.yaml` +```yaml +resolver: lts-16.20 + +extra-deps: +- git: git@github.com:discord-haskell/discord-haskell.git + commit: SOME_COMMIT_HASH + # go to https://github.com/discord-haskell/discord-haskell/commits/master + # and click on a commit to view the commit hash + # if you don't have a specific hash you're looking for, + # I recommend using the `Stack - Hackage` style installing +- emoji-0.1.0.2 +``` + +In `project.cabal` + +```cabal +cabal-version: 2.0 +name: haskell-bot +version: 0.0.1 +build-type: Simple + +executable haskell-bot + main-is: src/Main.hs + default-language: Haskell2010 + ghc-options: -threaded + build-depends: base + , text + , discord-haskell +``` diff --git a/deps/discord-haskell/docs/intents.md b/deps/discord-haskell/docs/intents.md new file mode 100644 index 0000000..ed0abc2 --- /dev/null +++ b/deps/discord-haskell/docs/intents.md @@ -0,0 +1,21 @@ + +### Intents + +#### Privileged Intents + + +Discord servers are enforcing a rule that bots cannot access Message Content without declaring a Privileged Intent. https://support-dev.discord.com/hc/en-us/articles/4404772028055 + +Bots in fewer than 75 (ie most bots) will need to check a box in the developer docs. Bots in >75 serves will need to be verified to have access to these intents. + +1. Go https://discord.com/developers/applications + +2. Click on the application you want to authorize + +3. In the taskbar on the left, select the 'Bot' tab + +4. Scroll down to "Privileged Gateway Intents" + +5. Enable Presence, Server Members, and Message Content intents. + + diff --git a/deps/discord-haskell/docs/todo.md b/deps/discord-haskell/docs/todo.md new file mode 100644 index 0000000..e555a85 --- /dev/null +++ b/deps/discord-haskell/docs/todo.md @@ -0,0 +1,36 @@ + +### TODO + + +#### Handle eventHandler backpressure + +What happens when discord sends more events than the user can handle? + +Each event forks a new thread at the moment we get it. What happens when the library receives 1000 events very quickly, how many threads do we spawn? + +#### Ensure ratelimiting is minimal + +discord/reest/http.hs implements ratelimiting https://discord.com/developers/docs/topics/rate-limits + +Print out all the headers as we get them and ensure the library is actually sending requests as fast as possible. + + +#### Cache + +Cache is a TODO at the moment. + +A cache is nice for a user to query, and we could do some automatic RestCall response caching for free performance. + +https://github.com/discord-haskell/discord-haskell/issues/44 wants to access the roles (in a `GuildMember` object) of the user who sent a `CreateMessage` event. However it only contains a `User` object. Need a separate RestCall to get the roles. + +https://github.com/discord-haskell/discord-haskell/issues/89 asks that a user can put their own data in the cache and access it. + +#### Higher level bot interface? easier to add state and stuff + +https://github.com/discord-haskell/discord-haskell/blob/master/examples/state-counter.hs + +https://github.com/discord-haskell/discord-haskell/issues/42 and https://github.com/discord-haskell/discord-haskell/issues/81 ask about how to store state in between event handler calls. + +https://github.com/discord-haskell/discord-haskell/issues/63 asks for docs on how to deploy a bot to heroku. + +The [state-counter.hs`](../examples/state-counter.hs) example shows how to increment a count between eventHandlers, and persist state to a file. diff --git a/deps/discord-haskell/docs/voice.md b/deps/discord-haskell/docs/voice.md new file mode 100644 index 0000000..6d44b49 --- /dev/null +++ b/deps/discord-haskell/docs/voice.md @@ -0,0 +1,5 @@ + +### Voice + +Voice & Audio is a separate package developed by +https://github.com/yutotakano/discord-haskell-voice diff --git a/deps/discord-haskell/examples/ExampleUtils.hs b/deps/discord-haskell/examples/ExampleUtils.hs new file mode 100644 index 0000000..517178b --- /dev/null +++ b/deps/discord-haskell/examples/ExampleUtils.hs @@ -0,0 +1,29 @@ +module ExampleUtils where + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Discord +import qualified Discord.Requests as R +import Discord.Types +import Text.Read (readMaybe) + +getToken :: IO T.Text +getToken = TIO.readFile "./examples/auth-token.secret" + +getGuildId :: IO GuildId +getGuildId = do + gids <- readFile "./examples/guildid.secret" + case readMaybe gids of + Just g -> pure g + Nothing -> error "could not read guild id from `guildid.secret`" + +-- | Given the test server and an action operating on a channel id, get the +-- first text channel of that server and use the action on that channel. +actionWithChannelId :: GuildId -> (ChannelId -> DiscordHandler a) -> DiscordHandler a +actionWithChannelId testserverid f = do + Right chans <- restCall $ R.GetGuildChannels testserverid + (f . channelId) (head (filter isTextChannel chans)) + where + isTextChannel :: Channel -> Bool + isTextChannel ChannelText {} = True + isTextChannel _ = False diff --git a/deps/discord-haskell/examples/cache.hs b/deps/discord-haskell/examples/cache.hs new file mode 100644 index 0000000..2e26f53 --- /dev/null +++ b/deps/discord-haskell/examples/cache.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +import UnliftIO (liftIO) + +import Discord + +import ExampleUtils (getToken) + +main :: IO () +main = cacheExample + +-- There's not much information in the Cache for now +-- but this program will show you what its got + +-- | Print cached Gateway info +cacheExample :: IO () +cacheExample = do + tok <- getToken + + _ <- runDiscord $ def { discordToken = tok + , discordOnStart = do + cache <- readCache + liftIO $ putStrLn ("Cached info from gateway: " <> show cache) + stopDiscord + } + pure () + diff --git a/deps/discord-haskell/examples/embed-photo.jpg b/deps/discord-haskell/examples/embed-photo.jpg Binary files differnew file mode 100644 index 0000000..99d7199 --- /dev/null +++ b/deps/discord-haskell/examples/embed-photo.jpg diff --git a/deps/discord-haskell/examples/example-setup b/deps/discord-haskell/examples/example-setup new file mode 100644 index 0000000..51458cc --- /dev/null +++ b/deps/discord-haskell/examples/example-setup @@ -0,0 +1,7 @@ +create a file named auth-token.secret and add your token (not the secret id) from +https://discord.com/developers/applications/me + +This is the Bot token (NOT CLIENT SECRET) from developer portal under the settings tab + +create a file named guildid.secret and add the guild id (server id) of your test server there. +your bot may need certain permissions to run specific examples, like the interaction-commands example. diff --git a/deps/discord-haskell/examples/gateway.hs b/deps/discord-haskell/examples/gateway.hs new file mode 100644 index 0000000..57e2e75 --- /dev/null +++ b/deps/discord-haskell/examples/gateway.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (forever) +import Control.Concurrent (forkIO, killThread) +import UnliftIO (liftIO) +import Control.Concurrent.Chan +import qualified Data.Text.IO as TIO + +import Discord +import Discord.Types + +import ExampleUtils (getToken, getGuildId) + +main :: IO () +main = gatewayExample + +-- | Prints every event as it happens +gatewayExample :: IO () +gatewayExample = do + tok <- getToken + testserverid <- getGuildId + + outChan <- newChan :: IO (Chan String) + + -- Events are processed in new threads, but stdout isn't + -- synchronized. We get ugly output when multiple threads + -- write to stdout at the same time + threadId <- forkIO $ forever $ readChan outChan >>= putStrLn + + err <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler testserverid + , discordOnEvent = eventHandler outChan + , discordOnEnd = killThread threadId + } + TIO.putStrLn err + +-- Events are enumerated in the discord docs +-- https://discord.com/developers/docs/topics/gateway#commands-and-events-gateway-events +eventHandler :: Chan String -> Event -> DiscordHandler () +eventHandler out event = liftIO $ writeChan out (show event <> "\n") + + +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do + let opts = RequestGuildMembersOpts + { requestGuildMembersOptsGuildId = testserverid + , requestGuildMembersOptsLimit = 100 + , requestGuildMembersOptsNamesStartingWith = "" + } + + -- gateway commands are enumerated in the discord docs + -- https://discord.com/developers/docs/topics/gateway#commands-and-events-gateway-commands + sendCommand (RequestGuildMembers opts) diff --git a/deps/discord-haskell/examples/interaction-commands-simple.hs b/deps/discord-haskell/examples/interaction-commands-simple.hs new file mode 100644 index 0000000..bf46321 --- /dev/null +++ b/deps/discord-haskell/examples/interaction-commands-simple.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Discord +import Discord.Types +import Discord.Interactions +import UnliftIO (liftIO) +import Data.List (find) +import Control.Monad (forM_) +import ExampleUtils (getToken, getGuildId) +import Data.Text (Text) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import qualified Discord.Requests as R +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + + +-- MAIN + +main :: IO () +main = do + tok <- getToken + testGuildId <- getGuildId + + botTerminationError <- runDiscord $ def + { discordToken = tok + , discordOnEvent = onDiscordEvent testGuildId + -- If you are using application commands, you might not need + -- message contents at all + , discordGatewayIntent = def { gatewayIntentMessageContent = False } + } + + echo $ "A fatal error occurred: " <> botTerminationError + + +-- UTILS + +echo :: MonadIO m => Text -> m () +echo = liftIO . TIO.putStrLn + +showT :: Show a => a -> Text +showT = T.pack . show + + +-- COMMANDS + +data SlashCommand = SlashCommand + { name :: Text + , registration :: Maybe CreateApplicationCommand + , handler :: Interaction -> Maybe OptionsData -> DiscordHandler () + } + +mySlashCommands :: [SlashCommand] +mySlashCommands = [ping] + +ping :: SlashCommand +ping = SlashCommand + { name = "ping" + , registration = createChatInput "ping" "responds pong" + , handler = \intr _options -> + void . restCall $ + R.CreateInteractionResponse + (interactionId intr) + (interactionToken intr) + (interactionResponseBasic "pong") + } + + +-- EVENTS + +onDiscordEvent :: GuildId -> Event -> DiscordHandler () +onDiscordEvent testGuildId = \case + Ready _ _ _ _ _ _ (PartialApplication appId _) -> onReady appId testGuildId + InteractionCreate intr -> onInteractionCreate intr + _ -> pure () + +onReady :: ApplicationId -> GuildId -> DiscordHandler () +onReady appId testGuildId = do + echo "Bot ready!" + + appCmdRegistrations <- mapM tryRegistering mySlashCommands + + case sequence appCmdRegistrations of + Left err -> + echo $ "[!] Failed to register some commands" <> showT err + + Right cmds -> do + echo $ "Registered " <> showT (length cmds) <> " command(s)." + unregisterOutdatedCmds cmds + + where + tryRegistering cmd = case registration cmd of + Just reg -> restCall $ R.CreateGuildApplicationCommand appId testGuildId reg + Nothing -> pure . Left $ RestCallErrorCode 0 "" "" + + unregisterOutdatedCmds validCmds = do + registered <- restCall $ R.GetGuildApplicationCommands appId testGuildId + case registered of + Left err -> + echo $ "Failed to get registered slash commands: " <> showT err + + Right cmds -> + let validIds = map applicationCommandId validCmds + outdatedIds = filter (`notElem` validIds) + . map applicationCommandId + $ cmds + in forM_ outdatedIds $ + restCall . R.DeleteGuildApplicationCommand appId testGuildId + +onInteractionCreate :: Interaction -> DiscordHandler () +onInteractionCreate = \case + cmd@InteractionApplicationCommand + { applicationCommandData = input@ApplicationCommandDataChatInput {} } -> + case + find (\c -> applicationCommandDataName input == name c) mySlashCommands + of + Just found -> + handler found cmd (optionsData input) + + Nothing -> + echo "Somehow got unknown slash command (registrations out of date?)" + + _ -> + pure () -- Unexpected/unsupported interaction type diff --git a/deps/discord-haskell/examples/interaction-commands.hs b/deps/discord-haskell/examples/interaction-commands.hs new file mode 100644 index 0000000..7d22825 --- /dev/null +++ b/deps/discord-haskell/examples/interaction-commands.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +import Control.Monad (when) +import qualified Data.ByteString as B +import Data.Char (isDigit) +import Data.Functor ((<&>)) +import Data.List (transpose) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Discord +import Discord.Interactions +import qualified Discord.Requests as R +import Discord.Types +import UnliftIO (liftIO) +import UnliftIO.Concurrent + +import ExampleUtils (getToken, getGuildId, actionWithChannelId) + +main :: IO () +main = interactionCommandExample + +void :: DiscordHandler (Either RestCallErrorCode b) -> DiscordHandler () +void = + ( >>= + ( \case + Left e -> liftIO $ print e + Right _ -> return () + ) + ) + +-- | Creates and manages a variety of interactions, including a tic tac toe example. +interactionCommandExample :: IO () +interactionCommandExample = do + tok <- getToken + testserverid <- getGuildId + + -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields + t <- + runDiscord $ + def + { discordToken = tok, + discordOnStart = startHandler testserverid, + discordOnEnd = liftIO $ putStrLn "Ended", + discordOnEvent = eventHandler testserverid, + discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "", + discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPresences = True} + } + TIO.putStrLn t + +-- If the start handler throws an exception, discord-haskell will gracefully shutdown +-- Use place to execute commands you know you want to complete +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do + let activity = + def + { activityName = "ping-pong", + activityType = ActivityTypeGame + } + let opts = + UpdateStatusOpts + { updateStatusOptsSince = Nothing, + updateStatusOptsGame = Just activity, + updateStatusOptsNewStatus = UpdateStatusOnline, + updateStatusOptsAFK = False + } + sendCommand (UpdateStatus opts) + + actionWithChannelId testserverid $ \cid -> + void $ + restCall $ + R.CreateMessage + cid + "Hello! I will reply to pings with pongs" + +-- | Example user command +exampleUserCommand :: Maybe CreateApplicationCommand +exampleUserCommand = createUser "usercomm" + +-- | Example slash command that has subcommands and multiple types of fields. +newExampleSlashCommand :: Maybe CreateApplicationCommand +newExampleSlashCommand = + createChatInput + "subtest" + "testing out subcommands" + >>= \d -> + Just $ + d + { createOptions = + Just + ( OptionsSubcommands + [ OptionSubcommandGroup + "frstsubcmdgrp" + Nothing + "the sub command group" + Nothing + [ OptionSubcommand + "frstsubcmd" + Nothing + "the first sub sub command" + Nothing + [ OptionValueString + "onestringinput" + Nothing + "two options" + Nothing + True + ( Right + [ Choice "green" Nothing "green", + Choice "red" Nothing "red" + ] + ) + Nothing + Nothing, + OptionValueInteger "oneintinput" Nothing "choices galore" Nothing False (Left False) Nothing Nothing + ] + ], + OptionSubcommandOrGroupSubcommand $ + OptionSubcommand + "frstsubcmd" + Nothing + "the first subcommand" + Nothing + [ OptionValueString + "onestringinput" + Nothing + "two options" + Nothing + True + ( Right + [ Choice "yellow" Nothing "yellow", + Choice "blue" Nothing "blue" + ] + ) + Nothing + Nothing + ], + OptionSubcommandOrGroupSubcommand $ + OptionSubcommand + "sndsubcmd" + Nothing + "the second subcommand" + Nothing + [ OptionValueBoolean + "trueorfalse" + Nothing + "true or false" + Nothing + True, + OptionValueNumber + "numbercomm" + Nothing + "number option" + Nothing + False + (Left True) + (Just 3.1415) + (Just 101), + OptionValueInteger + "numbercomm2" + Nothing + "another number option" + Nothing + False + (Right [Choice "one" Nothing 1, Choice "two" Nothing 2, Choice "minus 1" Nothing (-1)]) + (Just $ -1) + (Just $ -2), + OptionValueInteger + "numbercomm3" + Nothing + "another another number option" + Nothing + False + (Left True) + (Just $ -50) + (Just 50), + OptionValueUser + "user" + Nothing + "testing asking for a user" + Nothing + False, + OptionValueChannel + "channel" + Nothing + "testing asking for a channel" + Nothing + False + (Just [ChannelTypeOptionGuildVoice]), + OptionValueMentionable + "mentionable" + Nothing + "testing asking for a mentionable" + Nothing + False + ] + ] + ) + } + +-- | An example slash command. +exampleSlashCommand :: Maybe CreateApplicationCommand +exampleSlashCommand = + createChatInput + "test" + "here is a description" + >>= \cac -> + return $ + cac + { createOptions = + Just $ + OptionsValues + [ OptionValueString + "randominput" + Nothing + "I shall not" + Nothing + True + (Right [Choice "firstOpt" Nothing "yay", Choice "secondOpt" Nothing "nay"]) + Nothing + Nothing + ] + } + +exampleInteractionResponse :: OptionsData -> InteractionResponse +exampleInteractionResponse (OptionsDataValues [OptionDataValueString {optionDataValueString = s}]) = + interactionResponseBasic (T.pack $ "Here's the reply! You chose: " ++ show s) +exampleInteractionResponse _ = + interactionResponseBasic + "Something unexpected happened - the value was not what I expected!" + +getImage :: IO B.ByteString +getImage = return "\137PNG\r\n\SUB\n\NUL\NUL\NUL\rIHDR\NUL\NUL\NUL\SOH\NUL\NUL\NUL\SOH\b\STX\NUL\NUL\NUL\144wS\222\NUL\NUL\NUL\SOHsRGB\NUL\174\206\FS\233\NUL\NUL\NUL\EOTgAMA\NUL\NUL\177\143\v\252a\ENQ\NUL\NUL\NUL\tpHYs\NUL\NUL\SO\195\NUL\NUL\SO\195\SOH\199o\168d\NUL\NUL\NUL\fIDAT\CANWc\248\239\180\t\NUL\EOT7\SOH\244\162\155\ENQ\235\NUL\NUL\NUL\NULIEND\174B`\130" + + +-- If an event handler throws an exception, discord-haskell will continue to run +eventHandler :: GuildId -> Event -> DiscordHandler () +eventHandler testserverid event = case event of + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") + threadDelay (2 * 10 ^ (6 :: Int)) + + -- A very simple message. + void $ restCall (R.CreateMessage (messageChannelId m) "Pong!") + exampleImage <- liftIO getImage + + -- A more complex message. Text-to-speech, does not mention everyone nor + -- the user, and uses Discord native replies. + -- Use ":info" in ghci to explore the type + let opts :: R.MessageDetailedOpts + opts = + def + { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!", + R.messageDetailedTTS = True, + R.messageDetailedAllowedMentions = + Just $ + def + { R.mentionEveryone = False, + R.mentionRepliedUser = False + }, + R.messageDetailedReference = + Just $ + def {referenceMessageId = Just $ messageId m} + } + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts) + let opts' :: R.MessageDetailedOpts + opts' = + def + { R.messageDetailedContent = "An example of a message with buttons!", + R.messageDetailedComponents = + Just + [ ActionRowButtons + [ Button "Button 1" False ButtonStylePrimary (Just "Button 1") (Just (mkEmoji "🔥")), + Button "Button 2" True ButtonStyleSuccess (Just "Button 2") Nothing, + ButtonUrl + "https://github.com/discord-haskell/discord-haskell" + False + (Just "Button 3") + Nothing + ], + ActionRowSelectMenu + ( SelectMenu + "action select menu" + False + (SelectMenuDataText [ SelectOption "First option" "opt1" (Just "the only desc") Nothing Nothing, + SelectOption "Second option" "opt2" Nothing (Just (mkEmoji "😭")) (Just True), + SelectOption "third option" "opt3" Nothing Nothing Nothing, + SelectOption "fourth option" "opt4" Nothing Nothing Nothing, + SelectOption "fifth option" "opt5" Nothing Nothing Nothing + ]) + (Just "this is a place holder") + (Just 2) + (Just 5) + ), + ActionRowSelectMenu + ( SelectMenu + "user select menu" + False + (SelectMenuDataUser) + (Just "this is a place holder") + (Just 3) + (Just 3) + ), + ActionRowSelectMenu + ( SelectMenu + "channel select menu" + False + (SelectMenuDataChannels [ChannelTypeOptionGuildText,ChannelTypeOptionGuildPublicThread,ChannelTypeOptionGuildCategory]) + (Just "this is a place holder") + (Just 1) + (Just 1) + ) + ], + R.messageDetailedEmbeds = + Just + [ def + { createEmbedTitle = "Title", + createEmbedDescription = "the description", + createEmbedAuthorName = "Author name is Required", + createEmbedImage = Just (CreateEmbedImageUrl "https://media.discordapp.net/attachments/365969021083975681/936055590415921172/Warning.png"), + createEmbedColor = Just DiscordColorLuminousVividPink, + createEmbedAuthorIcon = Just (CreateEmbedImageUpload exampleImage) + }, + def {createEmbedTitle = "a different Title", createEmbedDescription = "another desc"} + ] + } + tictactoe :: R.MessageDetailedOpts + tictactoe = + def + { R.messageDetailedContent = "Playing tic tac toe! Player 0", + R.messageDetailedComponents = Just $ updateTicTacToe Nothing [] + } + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts') + void $ restCall (R.CreateMessageDetailed (messageChannelId m) tictactoe) + Ready _ _ _ _ _ _ (PartialApplication i _) -> do + vs <- + mapM + (maybe (return (Left $ RestCallErrorCode 0 "" "")) (restCall . R.CreateGuildApplicationCommand i testserverid)) + [exampleSlashCommand, exampleUserCommand, newExampleSlashCommand, createChatInput "modal" "modal test"] + liftIO (putStrLn $ "number of application commands added " ++ show (length vs)) + acs <- restCall (R.GetGuildApplicationCommands i testserverid) + case acs of + Left r -> liftIO $ print r + Right ls -> liftIO $ putStrLn $ "number of application commands total " ++ show (length ls) + InteractionCreate InteractionComponent {componentData = cb@ButtonData {componentDataCustomId = (T.take 3 -> "ttt")}, ..} -> case processTicTacToe cb interactionMessage of + [r] -> + void + ( restCall + ( R.CreateInteractionResponse + interactionId + interactionToken + (InteractionResponseUpdateMessage r) + ) + ) + r : rs -> + void + ( restCall $ + R.CreateInteractionResponse + interactionId + interactionToken + (InteractionResponseUpdateMessage r) + ) + >> mapM_ + ( restCall + . R.CreateFollowupInteractionMessage + interactionApplicationId + interactionToken + ) + rs + _ -> return () + InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataUser {applicationCommandDataName = nm, applicationCommandDataTargetUserId = uid, ..}, ..} -> + void $ + restCall + (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic $ "Command " <> nm <> T.pack (" selected user: " ++ show uid))) + InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "test", optionsData = Just d, ..}, ..} -> + void $ + restCall + (R.CreateInteractionResponse interactionId interactionToken (exampleInteractionResponse d)) + InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "subtest", optionsData = Just d, ..}, ..} -> void $ restCall (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic (T.pack $ "oh boy, subcommands! welp, here's everything I got from that: " <> show d))) + InteractionCreate InteractionComponent {componentData = ButtonData {..}, ..} -> + void $ + restCall + ( R.CreateInteractionResponse interactionId interactionToken $ + InteractionResponseChannelMessage + ( ( interactionResponseMessageBasic $ "You pressed the button " <> componentDataCustomId + ) + { interactionResponseMessageFlags = Just (InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]) + } + ) + ) + InteractionCreate InteractionComponent {componentData = SelectMenuData {componentDataValues = vs}, ..} -> + void + ( do + exampleImage <- liftIO getImage + aid <- readCache <&> cacheApplication <&> partialApplicationID + _ <- restCall (R.CreateInteractionResponse interactionId interactionToken InteractionResponseDeferChannelMessage) + restCall + ( R.CreateFollowupInteractionMessage + aid + interactionToken + (interactionResponseMessageBasic (T.pack $ "oh dear, select menu. thank you for waiting" <> show vs)) + { interactionResponseMessageEmbeds = + Just + [ def + { createEmbedTitle = "Select menu title", + createEmbedDescription = "Here is the select menu embed desc", + createEmbedAuthorName = "someunknownentity", + createEmbedImage = Just (CreateEmbedImageUrl "https://media.discordapp.net/attachments/365969021083975681/936055590415921172/Warning.png"), + createEmbedColor = Just DiscordColorDiscordBlurple, + createEmbedAuthorIcon = Just (CreateEmbedImageUpload exampleImage) + } + ] + } + ) + ) + InteractionCreate InteractionApplicationCommandAutocomplete {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "subtest", optionsData = Just _, ..}, ..} -> void (restCall $ R.CreateInteractionResponse interactionId interactionToken (InteractionResponseAutocompleteResult (InteractionResponseAutocompleteInteger [Choice "five" Nothing 5]))) + InteractionCreate i@InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "modal"}} -> + void $ + restCall + ( R.CreateInteractionResponse + (interactionId i) + (interactionToken i) + ( InteractionResponseModal + ( InteractionResponseModalData + "customidmodal" + "modal title" + [mkTextInput "textcid" "textlabel"] + ) + ) + ) + InteractionCreate i@InteractionModalSubmit {modalData = idm} -> void $ restCall (R.CreateInteractionResponse (interactionId i) (interactionToken i) (interactionResponseBasic (T.pack (show idm)))) + _ -> return () + +processTicTacToe :: ComponentData -> Message -> [InteractionResponseMessage] +processTicTacToe (ButtonData cid) m = case messageComponents m of + Nothing -> [interactionResponseMessageBasic "Sorry, I couldn't get the components on that message."] + (Just cs) -> + let newComp = newComp' cs + in ( ( interactionResponseMessageBasic + ("Some Tic Tac Toe! Player " <> (if '0' == T.last (messageContent m) then "1" else "0")) + ) + { interactionResponseMessageComponents = Just ((if checkTicTacToe newComp then (disableAll <$>) else id) newComp) + } + ) : + [interactionResponseMessageBasic ("Player " <> T.singleton player <> " has won!") | checkTicTacToe newComp] + where + player = T.last (messageContent m) + newComp' = updateTicTacToe (Just (cid, '0' == player)) + disableAll (ActionRowButtons cs) = ActionRowButtons $ (\c -> c {buttonDisabled = True}) <$> cs + disableAll c = c +processTicTacToe _ _ = [interactionResponseMessageBasic "Sorry, I couldn't understand that button."] + +checkTicTacToe :: [ActionRow] -> Bool +checkTicTacToe xs = checkRows unwrapped || checkRows unwrappedT || checkRows [diagonal unwrapped, diagonal (reverse <$> unwrapped)] + where + checkRows = any (\cbs -> all (\cb -> cb == head cbs && cb /= ButtonStyleSecondary) cbs) + unwrapped = (\(ActionRowButtons cbs) -> (\Button {buttonStyle = style} -> style) <$> cbs) <$> xs + unwrappedT = transpose unwrapped + diagonal [] = [] + diagonal ([] : _) = [] + diagonal (ys : yss) = head ys : diagonal (tail <$> yss) + +updateTicTacToe :: Maybe (T.Text, Bool) -> [ActionRow] -> [ActionRow] +updateTicTacToe Nothing _ = (\y -> ActionRowButtons $ (\x -> Button (T.pack $ "ttt " <> show x <> show y) False ButtonStyleSecondary (Just "[ ]") Nothing) <$> [0 .. 4]) <$> [0 .. 4] +updateTicTacToe (Just (tttxy, isFirst)) car + | not (checkIsValid tttxy) = car + | otherwise = (\(ActionRowButtons cbs) -> ActionRowButtons (changeIf <$> cbs)) <$> car + where + checkIsValid tttxy' = T.length tttxy' == 6 && all isDigit [T.index tttxy' 4, T.index tttxy' 5] + getxy tttxy' = (T.index tttxy' 4, T.index tttxy' 5) + (style, symbol) = if isFirst then (ButtonStyleSuccess, "[X]") else (ButtonStyleDanger, "[O]") + changeIf cb@Button {..} + | checkIsValid buttonCustomId && getxy tttxy == getxy buttonCustomId = cb {buttonDisabled = True, buttonStyle = style, buttonLabel = Just symbol} + | otherwise = cb + changeIf cb = cb + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent diff --git a/deps/discord-haskell/examples/ping-pong.hs b/deps/discord-haskell/examples/ping-pong.hs new file mode 100644 index 0000000..87ec08b --- /dev/null +++ b/deps/discord-haskell/examples/ping-pong.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text + +import Control.Monad (when, void) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import UnliftIO (liftIO) +import UnliftIO.Concurrent + +import Discord +import Discord.Types +import qualified Discord.Requests as R + +import ExampleUtils (getToken, getGuildId, actionWithChannelId) + +-- Allows this code to be an executable. See discord-haskell.cabal +main :: IO () +main = pingpongExample + +-- | Replies "pong" to every message that starts with "ping" +pingpongExample :: IO () +pingpongExample = do + tok <- getToken + testserverid <- getGuildId + + -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields + err <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler testserverid + , discordOnEnd = liftIO $ threadDelay (round (0.4 * 10^6)) >> putStrLn "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + , discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPresences =True} + } + + -- only reached on an unrecoverable error + -- put normal 'cleanup' code in discordOnEnd + TIO.putStrLn err + +-- If the start handler throws an exception, discord-haskell will gracefully shutdown +-- Use place to execute commands you know you want to complete +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do + liftIO $ putStrLn "Started ping-pong bot" + + let activity = def { activityName = "ping-pong" + , activityType = ActivityTypeGame + } + let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = UpdateStatusOnline + , updateStatusOptsAFK = False + } + sendCommand (UpdateStatus opts) + + actionWithChannelId testserverid $ \cid -> + void $ + restCall $ + R.CreateMessage + cid + "Hello! I will reply to pings with pongs" + + +-- If an event handler throws an exception, discord-haskell will continue to run +eventHandler :: Event -> DiscordHandler () +eventHandler event = case event of + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") + threadDelay (2 * 10 ^ (6 :: Int)) + + -- A very simple message. + Right m' <- restCall (R.CreateMessage (messageChannelId m) "Pong") + void $ restCall (R.EditMessage (messageChannelId m, messageId m') (def {R.messageDetailedContent=messageContent m' <> "!"})) + + latency <- getGatewayLatency + mLatency <- measureLatency + + -- A more complex message. Text-to-speech, does not mention everyone nor + -- the user, and uses Discord native replies. + -- Use ":info" in ghci to explore the type + let opts :: R.MessageDetailedOpts + opts = def { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!. Here's the current gateway latency: " <> (T.pack . show) ([latency, mLatency]) + , R.messageDetailedTTS = True + , R.messageDetailedAllowedMentions = Just $ + def { R.mentionEveryone = False + , R.mentionRepliedUser = False + } + , R.messageDetailedReference = Just $ + def { referenceMessageId = Just $ messageId m } + } + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts) + _ -> return () + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent diff --git a/deps/discord-haskell/examples/rest-without-gateway.hs b/deps/discord-haskell/examples/rest-without-gateway.hs new file mode 100644 index 0000000..5627f06 --- /dev/null +++ b/deps/discord-haskell/examples/rest-without-gateway.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Control.Monad (forever) +import Control.Concurrent -- Chans and Threads + +import Discord.Types +import qualified Discord.Requests as R + +import Discord.Internal.Rest (startRestThread, writeRestCall, RestCallInternalException(..)) + +import ExampleUtils (getToken, getGuildId) + +{- +Peel back the `runDiscord` abstraction + +Send an HTTP restcall without logging into the gateway +-} +main :: IO () +main = do + tok <- getToken + testserverid <- getGuildId + + -- SETUP LOG + printQueue <- newChan :: IO (Chan T.Text) + printThreadId <- forkIO $ forever $ readChan printQueue >>= TIO.putStrLn + + -- START REST LOOP THREAD + (restChan, restThreadId) <- startRestThread (Auth tok) printQueue + + -- a rest call to get the channels in which we will post a message + Right cs <- writeRestCall restChan (R.GetGuildChannels testserverid) + + -- ONE REST CALL + resp <- writeRestCall restChan (R.CreateMessage (channelId (head $ filter isTextChannel cs)) "Message") + case resp of + Right msg -> print $ "created message: " <> show msg + Left (RestCallInternalErrorCode _code _status _body) -> print "4XX style http error code" + Left (RestCallInternalHttpException _err) -> print "http exception (likely no connection)" + Left (RestCallInternalNoParse _err _jsondata) -> print "can't parse return JSON" + + -- CLEANUP + killThread printThreadId + killThread restThreadId + where + isTextChannel :: Channel -> Bool + isTextChannel ChannelText {} = True + isTextChannel _ = False diff --git a/deps/discord-haskell/examples/state-counter.hs b/deps/discord-haskell/examples/state-counter.hs new file mode 100644 index 0000000..f017d9c --- /dev/null +++ b/deps/discord-haskell/examples/state-counter.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Monad (when, void, forever) +import UnliftIO (try, IOException) -- liftIO +import UnliftIO.MVar +import UnliftIO.Chan +import UnliftIO.Concurrent (forkIO, killThread) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Discord +import Discord.Types +import qualified Discord.Requests as R + +import ExampleUtils (getToken) + +main :: IO () +main = stateExample + +data State = State { pingCount :: Integer } + deriving (Show, Read, Eq, Ord) + +-- | Counts how many pings we've seen across sessions +stateExample :: IO () +stateExample = do + tok <- getToken + + -- eventHandler is called concurrently, need to sync stdout + printQueue <- newChan :: IO (Chan T.Text) + threadId <- forkIO $ forever $ readChan printQueue >>= TIO.putStrLn + + -- try to read previous state, otherwise use 0 + state :: MVar (State) <- do + mfile <- try $ read . T.unpack <$> TIO.readFile "./cachedState" + s <- case mfile of + Right file -> do + writeChan printQueue "loaded state from file" + pure file + Left (_ :: IOException) -> do + writeChan printQueue "created new state" + pure $ State { pingCount = 0 } + newMVar s + + t <- runDiscord $ def { discordToken = tok + , discordOnStart = writeChan printQueue "starting ping loop" + , discordOnEvent = eventHandler state printQueue + , discordOnEnd = do killThread threadId + -- + s <- readMVar state + TIO.writeFile "./cachedState" (T.pack (show s)) + } + TIO.putStrLn t + + +eventHandler :: MVar State -> Chan T.Text -> Event -> DiscordHandler () +eventHandler state printQueue event = case event of + -- respond to message, and modify state + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + writeChan printQueue "got a ping!" + + s <- takeMVar state + + void $ restCall (R.CreateMessage (messageChannelId m) (T.pack ("Pong #" <> show (pingCount s)))) + + putMVar state $ State { pingCount = pingCount s + 1 } + + _ -> pure () + + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent diff --git a/deps/discord-haskell/src/Discord.hs b/deps/discord-haskell/src/Discord.hs new file mode 100644 index 0000000..5ed8bcf --- /dev/null +++ b/deps/discord-haskell/src/Discord.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Main module of the library +-- Contains all the entrypoints +module Discord + ( runDiscord + , restCall + , sendCommand + , readCache + , stopDiscord + , getGatewayLatency + , measureLatency + + , DiscordHandler + + , DiscordHandle + , Cache(..) + , RestCallErrorCode(..) + , RunDiscordOpts(..) + , FromJSON + , Request + , def + ) where + +import Prelude hiding (log) +import Control.Exception (Exception) +import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever, asks) +import Data.Aeson (FromJSON) +import Data.Default (Default, def) +import Data.IORef (writeIORef) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) + +import UnliftIO (race, try, finally, SomeException, IOException, readIORef) +import UnliftIO.Concurrent + +import Discord.Handle +import Discord.Internal.Rest +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 + { -- | 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 + , -- | Whether to use the cache (may use a lot of memory, only enable if it will be used!) + discordEnableCache :: Bool + } + +-- | Default values for `RunDiscordOpts` +instance Default RunDiscordOpts where + def = RunDiscordOpts { discordToken = "" + , discordOnStart = pure () + , discordOnEnd = pure () + , discordOnEvent = \_ -> pure () + , discordOnLog = \_ -> pure () + , discordForkThreadForEvents = True + , discordGatewayIntent = def + , discordEnableCache = False + } + +-- | Entrypoint to the library +runDiscord :: RunDiscordOpts -> IO T.Text +runDiscord opts = do + log <- newChan + logId <- liftIO $ startLogger (discordOnLog opts) log + (cache, cacheId) <- liftIO $ startCacheThread (discordEnableCache opts) log + (rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log + (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) (discordGatewayIntent opts) cache log + + libE <- newEmptyMVar + + let handle = DiscordHandle { discordHandleRestChan = rest + , discordHandleGateway = gate + , discordHandleCache = cache + , discordHandleLog = log + , discordHandleLibraryError = libE + , discordHandleThreads = + [ HandleThreadIdLogger logId + , HandleThreadIdRest restId + , HandleThreadIdCache cacheId + , HandleThreadIdGateway gateId + ] + } + + 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 + case resp of + Left (RestCallInternalErrorCode c e1 e2) -> libError $ + "HTTP Error Code " <> T.pack (show c) <> " " <> TE.decodeUtf8 e1 + <> " " <> TE.decodeUtf8 e2 + Left (RestCallInternalHttpException e) -> libError ("HTTP Exception - " <> T.pack (show e)) + Left (RestCallInternalNoParse _ _) -> libError "Couldn't parse GetCurrentUser" + _ -> do me <- liftIO . runReaderT (try $ discordOnStart opts) $ handle + case me of + Left (e :: SomeException) -> libError ("discordOnStart handler stopped on an exception:\n\n" <> T.pack (show e)) + Right _ -> loop + where + libError :: T.Text -> IO T.Text + libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg + + loop :: IO T.Text + loop = do next <- race (readMVar (discordHandleLibraryError handle)) + (readChan (gatewayHandleEvents (discordHandleGateway handle))) + case next of + Left err -> libError err + Right (Left err) -> libError (T.pack (show err)) + Right (Right event) -> do + let userEvent = userFacingEvent event + let action = if discordForkThreadForEvents opts then void . forkIO + else id + action $ do me <- liftIO . runReaderT (try $ discordOnEvent opts userEvent) $ handle + case me of + Left (e :: SomeException) -> writeChan (discordHandleLog handle) + ("eventhandler - crashed on [" <> T.pack (show userEvent) <> "] " + <> " with error: " <> T.pack (show e)) + 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 + empty <- isEmptyMVar (discordHandleLibraryError h) + if not empty + then pure (Left (RestCallErrorCode 400 "Library Stopped Working" "")) + else do + resp <- liftIO $ writeRestCall (discordHandleRestChan h) r + case resp of + Right x -> pure (Right x) + Left (RestCallInternalErrorCode c e1 e2) -> do + pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2))) + Left (RestCallInternalHttpException _) -> + threadDelay (10 * 10^(6 :: Int)) >> restCall r + Left (RestCallInternalNoParse err dat) -> do + let formaterr = T.pack ("restcall - parse exception [" <> err <> "]" + <> " while handling" <> show dat) + writeChan (discordHandleLog h) formaterr + pure (Left (RestCallErrorCode 400 "Library Parse Exception" formaterr)) + +-- | Send a user GatewaySendable +sendCommand :: GatewaySendable -> DiscordHandler () +sendCommand e = do + h <- ask + writeChan (gatewayHandleUserSendables (discordHandleGateway h)) e + case e of + UpdateStatus opts -> liftIO $ writeIORef (gatewayHandleLastStatus (discordHandleGateway h)) (Just opts) + _ -> pure () + +-- | Access the current state of the gateway cache +readCache :: DiscordHandler Cache +readCache = do + h <- ask + merr <- readMVar (cacheHandleCache (discordHandleCache h)) + case merr of + Left (c, _) -> pure c + Right c -> pure c + + +-- | Stop all the background threads +stopDiscord :: DiscordHandler () +stopDiscord = do h <- ask + _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed" + threadDelay (10^(6 :: Int) `div` 10) + mapM_ (killThread . toId) (discordHandleThreads h) + where toId t = case t of + HandleThreadIdRest a -> a + HandleThreadIdGateway a -> a + 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 + case me of + Right _ -> pure () + Left (_ :: IOException) -> + -- writeChan logC "Log handler failed" + pure () + +-- | Read the gateway latency from the last time we sent and received a +-- Heartbeat. From Europe tends to give ~110ms +getGatewayLatency :: DiscordHandler NominalDiffTime +getGatewayLatency = do + gw <- asks discordHandleGateway + (send1, send2) <- readIORef (gatewayHandleHeartbeatTimes gw) + + ack <- readIORef (gatewayHandleHeartbeatAckTimes gw) + + pure . diffUTCTime ack $ + if ack > send1 -- if the ack is before the send just gone, use the previous send + then send1 + else send2 + +-- | Measure the current latency by making a request and measuring the time +-- taken. From Europe tends to give 200ms-800ms. +-- +-- The request is getting the bot's user, which requires the `identify` scope. +measureLatency :: DiscordHandler NominalDiffTime +measureLatency = do + startTime <- liftIO getCurrentTime + _ <- restCall GetCurrentUser + endTime <- liftIO getCurrentTime + pure $ diffUTCTime endTime startTime + +-- internal note: it seems bad that it's taking 2x-8x as much time to perform +-- this specific request, considering that the latency we expect is much less. +-- might be worth looking into efficiencies or a better event to use. diff --git a/deps/discord-haskell/src/Discord/Handle.hs b/deps/discord-haskell/src/Discord/Handle.hs new file mode 100644 index 0000000..48d6641 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Handle.hs @@ -0,0 +1,38 @@ +-- | The Discord Handle. Holds all the information related to the connection. +module Discord.Handle + ( DiscordHandle(..) + , HandleThreadId(..) + ) where + +import Control.Concurrent (ThreadId, Chan, MVar) +import qualified Data.Text as T + +import Discord.Internal.Rest (RestChanHandle(..)) +import Discord.Internal.Gateway (GatewayHandle(..), CacheHandle(..)) + +-- | Thread Ids marked by what type they are +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 + { -- | 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/deps/discord-haskell/src/Discord/Interactions.hs b/deps/discord-haskell/src/Discord/Interactions.hs new file mode 100644 index 0000000..45be2da --- /dev/null +++ b/deps/discord-haskell/src/Discord/Interactions.hs @@ -0,0 +1,8 @@ +module Discord.Interactions + ( module Discord.Internal.Types.ApplicationCommands, + module Discord.Internal.Types.Interactions, + ) +where + +import Discord.Internal.Types.ApplicationCommands +import Discord.Internal.Types.Interactions diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Gateway.hs new file mode 100644 index 0000000..f07be39 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Gateway.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides a rather raw interface to the websocket events +-- through a real-time Chan +module Discord.Internal.Gateway + ( GatewayHandle(..) + , CacheHandle(..) + , GatewayException(..) + , Cache(..) + , startCacheThread + , startGatewayThread + , module Discord.Internal.Types + ) where + +import Prelude hiding (log) +import Control.Concurrent.Chan (newChan, dupChan, Chan) +import Control.Concurrent (forkIO, ThreadId, newEmptyMVar, MVar) +import Data.IORef (newIORef) +import qualified Data.Text as T +import Data.Time (getCurrentTime) + +import Discord.Internal.Types (Auth, EventInternalParse, GatewayIntent) +import Discord.Internal.Gateway.EventLoop (connectionLoop, GatewayHandle(..), GatewayException(..)) +import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..)) + +-- | Starts a thread for the cache +startCacheThread :: Bool -> Chan T.Text -> IO (CacheHandle, ThreadId) +startCacheThread isEnabled log = do + events <- newChan :: IO (Chan (Either GatewayException EventInternalParse)) + cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache)) + let cacheHandle = CacheHandle events cache + tid <- forkIO $ cacheLoop isEnabled cacheHandle log + pure (cacheHandle, tid) + +-- | Create a Chan for websockets. This creates a thread that +-- writes all the received EventsInternalParse to the Chan +startGatewayThread :: Auth -> GatewayIntent -> CacheHandle -> Chan T.Text -> IO (GatewayHandle, ThreadId) +startGatewayThread auth intent cacheHandle log = do + events <- dupChan (cacheHandleEvents cacheHandle) + sends <- newChan + status <- newIORef Nothing + seqid <- newIORef 0 + seshid <- newIORef "" + host <- newIORef "gateway.discord.gg" + currTime <- getCurrentTime + hbAcks <- newIORef currTime + hbSends <- newIORef (currTime, currTime) + let gatewayHandle = GatewayHandle events sends status seqid seshid host hbAcks hbSends + tid <- forkIO $ connectionLoop auth intent gatewayHandle log + pure (gatewayHandle, tid) diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs new file mode 100644 index 0000000..a4f228a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | Query info about connected Guilds and Channels +module Discord.Internal.Gateway.Cache where + +import Prelude hiding (log) +import Control.Monad (forever, join) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.Foldable (foldl') +import qualified Data.Map.Strict as M +import qualified Data.Text as T + +import Discord.Internal.Types +import Discord.Internal.Gateway.EventLoop + +data Cache = Cache + { cacheCurrentUser :: !User + , cacheDMChannels :: !(M.Map ChannelId Channel) + , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData))) + , cacheChannels :: !(M.Map ChannelId Channel) + , cacheApplication :: !PartialApplication + } deriving (Show) + +data CacheHandle = CacheHandle + { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse) + , cacheHandleCache :: MVar (Either (Cache, GatewayException) Cache) + } + +cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO () +cacheLoop isEnabled cacheHandle log = do + ready <- readChan eventChan + case ready of + Right (InternalReady _ user _ _ _ _ pApp) -> do + putMVar cache (Right (Cache user M.empty M.empty M.empty pApp)) + loop + Right r -> + writeChan log ("cache - stopping cache - expected Ready event, but got " <> T.pack (show r)) + Left e -> + writeChan log ("cache - stopping cache - gateway exception " <> T.pack (show e)) + where + cache = cacheHandleCache cacheHandle + eventChan = cacheHandleEvents cacheHandle + + loop :: IO () + loop = forever $ do + eventOrExcept <- readChan eventChan + if not isEnabled + then return () + else do + minfo <- takeMVar cache + case minfo of + Left nope -> putMVar cache (Left nope) + Right info -> case eventOrExcept of + Left e -> putMVar cache (Left (info, e)) + Right event -> putMVar cache $! Right $! adjustCache info event + +adjustCache :: Cache -> EventInternalParse -> Cache +adjustCache minfo event = case event of + InternalReady _ _ gus _ _ _ pa -> minfo { cacheApplication = pa, cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) } + + InternalGuildCreate guild guildData -> + let newChans = guildCreateChannels guildData + g = M.insert (guildId guild) (Just (guild, Just guildData)) (cacheGuilds minfo) + c = M.union + (M.fromList [ (channelId ch, ch) | ch <- newChans ]) + (cacheChannels minfo) + in minfo { cacheGuilds = g, cacheChannels = c } + InternalGuildUpdate guild -> + let gs = M.alter (\case Just (Just (_, mCD)) -> Just (Just (guild, mCD)) ; _ -> Just (Just (guild, Nothing)); ) (guildId guild) $ cacheGuilds minfo + in minfo { cacheGuilds = gs } + InternalGuildDelete guild -> + let + toDelete = join $ cacheGuilds minfo M.!? idOnceAvailable guild + extraData = snd =<< toDelete + channels = maybe [] (fmap channelId . guildCreateChannels) extraData + g = M.delete (idOnceAvailable guild) (cacheGuilds minfo) + c = foldl' (flip M.delete) (cacheChannels minfo) channels + in minfo { cacheGuilds = g, cacheChannels = c } + InternalChannelCreate c -> + let cm = M.insert (channelId c) c (cacheChannels minfo) + in minfo { cacheChannels = cm } + InternalChannelUpdate c -> + let cm = M.insert (channelId c) c (cacheChannels minfo) + in minfo { cacheChannels = cm } + InternalChannelDelete c -> + let cm = M.delete (channelId c) (cacheChannels minfo) + in minfo { cacheChannels = cm } + _ -> minfo diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway/EventLoop.hs b/deps/discord-haskell/src/Discord/Internal/Gateway/EventLoop.hs new file mode 100644 index 0000000..dfcd00f --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Gateway/EventLoop.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Provides logic code for interacting with the Discord websocket +-- gateway. Realistically, this is probably lower level than most +-- people will need +module Discord.Internal.Gateway.EventLoop where + +import Prelude hiding (log) + +import Control.Monad (forever, void) +import Control.Monad.Random (getRandomR) +import Control.Concurrent.Async (race) +import Control.Concurrent.Chan +import Control.Concurrent (threadDelay, killThread, forkIO) +import Control.Exception.Safe (try, finally, SomeException) +import Data.IORef +import Data.Aeson (eitherDecode, encode) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as BL +import Data.Time (getCurrentTime) + +import Wuss (runSecureClient) +import Network.Socket (HostName) +import Network.WebSockets (ConnectionException(..), Connection, + receiveData, sendTextData, sendClose) + +import Discord.Internal.Types +import Discord.Internal.Rest.Prelude (apiVersion) + + +-- | Info the event processing loop needs to +data GatewayHandle = GatewayHandle + { -- | 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, + -- | Which discord gateway to connect to. This should contain a default value + -- ("gateway.discord.gg") on first connect, but on subsequent Resumes this + -- may contain a different value. This should never contain trailing slashes, + -- or any "wss://" prefixes, since HostNames of this kind are not supported + -- by the websockets library. + gatewayHandleHostname :: IORef HostName, + -- | The last time a heartbeatack was received + gatewayHandleHeartbeatAckTimes :: IORef UTCTime, + -- | The last two times a heartbeat was sent + gatewayHandleHeartbeatTimes :: IORef (UTCTime, UTCTime) + } + +-- | Ways the gateway connection can fail with no possibility of recovery. +newtype GatewayException = GatewayExceptionIntent T.Text + deriving (Show) + + +-- | State of the eventloop +data LoopState = LoopStart + | LoopClosed + | LoopReconnect + deriving Show + +-- | Info the sendableLoop reads when it writes to the websocket +data SendablesData = SendablesData + { sendableConnection :: Connection + , librarySendables :: Chan GatewaySendableInternal + , startsendingUsers :: IORef Bool + , heartbeatInterval :: Integer + } + + +-- | 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 + + -- | Main connection loop. Catch exceptions and reconnect. + outerloop :: LoopState -> IO () + outerloop state = do + gatewayHost <- readIORef (gatewayHandleHostname gatewayHandle) + mfirst <- firstmessage state -- construct first message + case mfirst of + Nothing -> pure () -- close + + Just message -> do + nextstate <- try (startOneConnection gatewayHost 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 + + -- | 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 + + startOneConnection + :: HostName + -- ^ The gateway address to connect to. Should be "gateway.discord.gg" on first try, but + -- all Resumes should go to the resume_gateway_url specified in the Ready event + -- https://discord.com/developers/docs/change-log#sessionspecific-gateway-resume-urls + -> GatewaySendableInternal + -- ^ The first message to send. Either an Identify or Resume. + -> IO LoopState + startOneConnection gatewayAddr message = runSecureClient gatewayAddr 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 (gatewayHandleHeartbeatTimes gatewayHandle) (gatewayHandleLastSequenceId gatewayHandle) + writeChan internal message + + -- 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 (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 resumeHost _ _) -> do + writeIORef (gatewayHandleSessionId thehandle) seshID + writeIORef (gatewayHandleHostname thehandle) resumeHost + _ -> writeIORef (startsendingUsers sendablesData) True + loop + Right (Hello _interval) -> do writeChan log "eventloop - unexpected hello" + loop + Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq + sendHeartbeat sendablesData (gatewayHandleHeartbeatTimes thehandle) sq + loop + Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart + Right Reconnect -> pure LoopReconnect + Right HeartbeatAck -> do + currTime <- getCurrentTime + _ <- atomicModifyIORef' (gatewayHandleHeartbeatAckTimes thehandle) (dupe . const currTime) + loop + Right (ParseError _) -> 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 + -- https://discord.com/developers/docs/topics/opcodes-and-status-codes#gateway-gateway-close-event-codes + -- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent#properties + 1000 -> pure LoopReconnect + 1001 -> pure LoopReconnect + 4000 -> pure LoopReconnect + 4006 -> pure LoopStart + 4007 -> pure LoopStart + 4014 -> do writeChan eventChan (Left (GatewayExceptionIntent $ + "Tried to declare an unauthorized GatewayIntent. " <> + "Use the discord app manager to authorize by following: " <> + "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/discord-haskell/discord-haskell/issues") + pure LoopStart + Left _ -> pure LoopReconnect + + +-- | 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 + res <- race (threadDelay (fromInteger ((interval * 1000 * 3) `div` 2))) + (getPayload (sendableConnection sendablesData) log) + case res of + 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 + case eitherDecode msg' of + Right msg -> pure msg + Left err -> do writeChan log ("gateway - received exception [" <> T.pack err <> "]" + <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg')) + pure (ParseError (T.pack err)) + +-- | Infinite loop to send heartbeats to the chan +heartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> IORef Integer -> IO () +heartbeat sendablesData sendTimes seqKey = do + threadDelay (3 * 10^(6 :: Int)) + forever $ do + num <- readIORef seqKey + sendHeartbeat sendablesData sendTimes num + threadDelay (fromInteger (heartbeatInterval sendablesData * 1000)) + +sendHeartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO () +sendHeartbeat sendablesData sendTimes seqKey = do + currTime <- getCurrentTime + _ <- atomicModifyIORef' sendTimes (dupe . (currTime,) . fst) + writeChan (librarySendables sendablesData) (Heartbeat seqKey) + +-- | 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 = sendLoop + where + sendLoop = do + -- send a ~120 events a min by delaying + threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) + -- payload :: Either GatewaySendableInternal GatewaySendable + payload <- race nextLibrary nextUser + 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 + +dupe :: a -> (a, a) +dupe a = (a, a) diff --git a/deps/discord-haskell/src/Discord/Internal/Rest.hs b/deps/discord-haskell/src/Discord/Internal/Rest.hs new file mode 100644 index 0000000..0ddaff0 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides a higher level interface to the rest functions. +-- Preperly writes to the rate-limit loop. Creates separate +-- MVars for each call +module Discord.Internal.Rest + ( module Discord.Internal.Types + , RestChanHandle(..) + , Request(..) + , writeRestCall + , startRestThread + , RestCallInternalException(..) + ) where + +import Prelude hiding (log) +import Data.Aeson (FromJSON, eitherDecode) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent (forkIO, ThreadId) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + + +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)) + } + +-- | Starts the http request thread. Please only call this once +startRestThread :: Auth -> Chan T.Text -> IO (RestChanHandle, ThreadId) +startRestThread auth log = do + c <- newChan + tid <- forkIO $ restLoop auth c log + pure (RestChanHandle c, tid) + +-- | Execute a request blocking until a response is received +writeRestCall :: (Request (r a), FromJSON a) => RestChanHandle -> r a -> IO (Either RestCallInternalException a) +writeRestCall c req = do + m <- newEmptyMVar + writeChan (restHandleChan c) (majorRoute req, jsonRequest req, m) + r <- readMVar m + pure $ case eitherDecode <$> r of + Right (Right o) -> Right o + (Right (Left er)) -> Left (RestCallInternalNoParse er (case r of + Right x -> x + Left _ -> "")) + Left e -> Left e + + diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationCommands.hs b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationCommands.hs new file mode 100644 index 0000000..9ed33b3 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationCommands.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Discord.Internal.Rest.ApplicationCommands where + +import Data.Aeson (Value) +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Discord.Internal.Types.ApplicationCommands + ( ApplicationCommandPermissions, + GuildApplicationCommandPermissions(GuildApplicationCommandPermissions), + EditApplicationCommand, + CreateApplicationCommand, + ApplicationCommand ) +import Network.HTTP.Req as R + +instance Request (ApplicationCommandRequest a) where + jsonRequest = applicationCommandJsonRequest + majorRoute = applicationCommandMajorRoute + +-- | Requests related to application commands +data ApplicationCommandRequest a where + -- | 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 + +-- | The major routes identifiers for `ApplicationCommandRequest`s +applicationCommandMajorRoute :: ApplicationCommandRequest a -> String +applicationCommandMajorRoute a = case a of + (GetGlobalApplicationCommands aid) -> "get_glob_appcomm" <> show aid + (CreateGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (GetGlobalApplicationCommand aid _) -> "get_glob_appcomm" <> show aid + (EditGlobalApplicationCommand aid _ _) -> "write_glob_appcomm" <> show aid + (DeleteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (BulkOverWriteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (GetGuildApplicationCommands aid _) -> "get_appcomm" <> show aid + (CreateGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (GetGuildApplicationCommand aid _ _) -> "get_appcomm" <> show aid + (EditGuildApplicationCommand aid _ _ _) -> "write_appcomm" <> show aid + (DeleteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (BulkOverWriteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (GetGuildApplicationCommandPermissions aid _) -> "appcom_perm " <> show aid + (GetApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid + (EditApplicationCommandPermissions aid _ _ _) -> "appcom_perm " <> show aid + +-- | The `JsonRequest`s for `ApplicationCommandRequest`s +applicationCommandJsonRequest :: ApplicationCommandRequest a -> JsonRequest +applicationCommandJsonRequest a = case a of + (GetGlobalApplicationCommands aid) -> + Get (applications aid /: "commands") mempty + (CreateGlobalApplicationCommand aid cac) -> + Post (applications aid /: "commands") (convert cac) mempty + (GetGlobalApplicationCommand aid aci) -> + Get (applications aid /: "commands" /~ aci) mempty + (EditGlobalApplicationCommand aid aci eac) -> + Patch (applications aid /: "commands" /~ aci) (convert eac) mempty + (DeleteGlobalApplicationCommand aid aci) -> + 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 + (CreateGuildApplicationCommand aid gid cac) -> + Post (applications aid /: "guilds" /~ gid /: "commands") (convert cac) mempty + (GetGuildApplicationCommand aid gid aci) -> + Get (applications aid /: "guilds" /~ gid /: "commands" /~ aci) mempty + (EditGuildApplicationCommand aid gid aci eac) -> + Patch (applications aid /: "guilds" /~ gid /: "commands" /~ aci) (convert eac) mempty + (DeleteGuildApplicationCommand aid gid aci) -> + Delete (applications aid /: "guilds" /~ gid /: "commands" /~ aci) mempty + (BulkOverWriteGuildApplicationCommand aid gid cacs) -> + Put (applications aid /: "guilds" /~ gid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty + (GetGuildApplicationCommandPermissions aid gid) -> + Get (applications aid /: "guilds" /~ gid /: "commands" /: "permissions") mempty + (GetApplicationCommandPermissions aid gid cid) -> + 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 + where + convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) + convert = (pure @RestIO) . R.ReqBodyJson . toJSON diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs new file mode 100644 index 0000000..1024d9d --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Channel + ( ChannelRequest(..) + , MessageDetailedOpts(..) + , AllowedMentions(..) + , ReactionTiming(..) + , MessageTiming(..) + , ChannelInviteOpts(..) + , ModifyChannelOpts(..) + , ChannelPermissionsOpts(..) + , GroupDMAddRecipientOpts(..) + , StartThreadOpts(..) + , StartThreadNoMessageOpts(..) + , ListThreads(..) + ) where + + +import Data.Aeson +import Data.Default (Default, def) +import Data.Emoji (unicodeByName) +import qualified Data.Text as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS) +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Control.Monad (join) + +instance Request (ChannelRequest a) where + majorRoute = channelMajorRoute + jsonRequest = channelJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data ChannelRequest a where + -- | Gets a channel by its id. + GetChannel :: ChannelId -> ChannelRequest Channel + -- | Edits channels options. + ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel + -- | Deletes a channel if its id doesn't equal to the id of guild. + DeleteChannel :: ChannelId -> ChannelRequest Channel + -- | Gets a messages from a channel with limit of 100 per request. + GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] + -- | Gets a message in a channel by its id. + GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message + -- | Sends a message to a channel. + CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message + -- | Sends a message with granular controls. + CreateMessageDetailed :: ChannelId -> MessageDetailedOpts -> ChannelRequest Message + -- | Add an emoji reaction to a message. ID must be present for custom emoji + CreateReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + -- | Remove a Reaction this bot added + DeleteOwnReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + -- | Remove a Reaction someone else added + DeleteUserReaction :: (ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () + -- | Deletes all reactions of a single emoji on a message + DeleteSingleReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + -- | List of users that reacted with this emoji + GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest [User] + -- | Delete all reactions on a message + DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () + -- | Edits a message content. + EditMessage :: (ChannelId, MessageId) -> MessageDetailedOpts + -> ChannelRequest Message + -- | Deletes a message. + DeleteMessage :: (ChannelId, MessageId) -> ChannelRequest () + -- | Deletes a group of messages. + BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () + -- | Edits a permission overrides for a channel. + 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 -> Either RoleId UserId -> ChannelRequest () + -- | Sends a typing indicator a channel which lasts 10 seconds. + TriggerTypingIndicator :: ChannelId -> ChannelRequest () + -- | Gets all pinned messages of a channel. + GetPinnedMessages :: ChannelId -> ChannelRequest [Message] + -- | Pins a message. + AddPinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + -- | Unpins a message. + DeletePinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + -- | Adds a recipient to a Group DM using their access token + GroupDMAddRecipient :: ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () + -- | Removes a recipient from a Group DM + GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () + -- | Start a thread from a message + StartThreadFromMessage :: ChannelId -> MessageId -> StartThreadOpts -> ChannelRequest Channel + -- | Start a thread without a message + StartThreadNoMessage :: ChannelId -> StartThreadNoMessageOpts -> ChannelRequest Channel + -- | Join a thread + JoinThread :: ChannelId -> ChannelRequest () + -- | Add a thread member + AddThreadMember :: ChannelId -> UserId -> ChannelRequest () + -- | Leave a thread + LeaveThread :: ChannelId -> ChannelRequest () + -- | Remove a thread member + RemoveThreadMember :: ChannelId -> UserId -> ChannelRequest () + -- | Get a thread member + GetThreadMember :: ChannelId -> UserId -> ChannelRequest ThreadMember + -- | List the thread members + ListThreadMembers :: ChannelId -> ChannelRequest [ThreadMember] + -- | List public archived threads in the given channel. Optionally before a + -- given time, and optional maximum number of threads. Returns the threads, + -- thread members, and whether there are more to collect. + -- Requires the READ_MESSAGE_HISTORY permission. + ListPublicArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + -- | List private archived threads in the given channel. Optionally before a + -- given time, and optional maximum number of threads. Returns the threads, + -- thread members, and whether there are more to collect. + -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. + ListPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + -- | List joined private archived threads in the given channel. Optionally + -- before a given time, and optional maximum number of threads. Returns the + -- threads, thread members, and whether there are more to collect. + -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. + ListJoinedPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + + +-- | Options for `CreateMessageDetailed` requests. +data MessageDetailedOpts = MessageDetailedOpts + { -- | 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 + def = MessageDetailedOpts { messageDetailedContent = "" + , messageDetailedTTS = False + , messageDetailedEmbeds = Nothing + , messageDetailedFile = Nothing + , messageDetailedAllowedMentions = Nothing + , messageDetailedReference = Nothing + , messageDetailedComponents = Nothing + , messageDetailedStickerIds = Nothing + } + +-- | Data constructor for `GetReactions` requests +data ReactionTiming = BeforeReaction MessageId + | AfterReaction MessageId + | LatestReaction + deriving (Show, Read, Eq, Ord) + +reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https +reactionTimingToQuery t = case t of + (BeforeReaction snow) -> "before" R.=: show snow + (AfterReaction snow) -> "after" R.=: show snow + LatestReaction -> mempty + +-- | Data constructor for `GetChannelMessages` requests. +-- +-- See <https://discord.com/developers/docs/resources/channel#get-channel-messages> +data MessageTiming = AroundMessage MessageId + | BeforeMessage MessageId + | AfterMessage MessageId + | LatestMessages + deriving (Show, Read, Eq, Ord) + +messageTimingToQuery :: MessageTiming -> R.Option 'R.Https +messageTimingToQuery t = case t of + (AroundMessage snow) -> "around" R.=: show snow + (BeforeMessage snow) -> "before" R.=: show snow + (AfterMessage snow) -> "after" R.=: show snow + LatestMessages -> mempty + +-- | Options for `CreateChannelInvite` requests +data ChannelInviteOpts = ChannelInviteOpts + { -- | 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 + toJSON ChannelInviteOpts{..} = objectFromMaybes + ["max_age" .=? channelInviteOptsMaxAgeSeconds, + "max_uses" .=? channelInviteOptsMaxUsages, + "temporary" .=? channelInviteOptsIsTemporary, + "unique" .=? channelInviteOptsDontReuseSimilarInvite ] + +-- | Options for `ModifyChannel` requests +data ModifyChannelOpts = ModifyChannelOpts + { -- | (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 Nothing + +instance ToJSON ModifyChannelOpts where + toJSON ModifyChannelOpts{..} = objectFromMaybes + ["name" .=? modifyChannelName, + "position" .=? modifyChannelPosition, + "topic" .=? modifyChannelTopic, + "nsfw" .=? modifyChannelNSFW, + "bitrate" .=? modifyChannelBitrate, + "rate_limit_per_user" .=? modifyChannelUserRateLimit, + "user_limit" .=? modifyChannelUserLimit, + "permission_overwrites" .=? modifyChannelPermissionOverwrites, + "parent_id" .=? modifyChannelParentId, + "default_auto_archive_duration" .=? modifyChannelDefaultAutoArchive, + "archived" .=? modifyChannelThreadArchived, + "auto_archive_duration" .=? modifyChannelThreadAutoArchive, + "locked" .=? modifyChannelThreadLocked, + "invitable" .=? 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 + { -- | 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) + +-- | Options for `GroupDMAddRecipient` request +-- +-- See <https://discord.com/developers/docs/resources/channel#group-dm-add-recipient> +data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts + { -- | 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 + { -- | 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 + toJSON StartThreadOpts{..} = objectFromMaybes + [ "name" .== startThreadName + , "auto_archive_duration" .=? startThreadAutoArchive + , "rate_limit_per_user" .=? startThreadRateLimit + ] + +-- | Options for `StartThreadNoMessage` request +data StartThreadNoMessageOpts = StartThreadNoMessageOpts + { -- | Base options for the thread + startThreadNoMessageBaseOpts :: StartThreadOpts + , -- | The type of thread to create + -- + -- Can be @10@, @11@, or @12@. See + -- <https://discord.com/developers/docs/resources/channel#channel-object-channel-types> + 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 + toJSON StartThreadNoMessageOpts{..} = objectFromMaybes + [ "name" .== startThreadName startThreadNoMessageBaseOpts + , "auto_archive_duration" .=? startThreadAutoArchive startThreadNoMessageBaseOpts + , "rate_limit_per_user" .=? startThreadRateLimit startThreadNoMessageBaseOpts + , "type" .== startThreadNoMessageType + , "invitable" .=? startThreadNoMessageInvitable + ] + +-- | Result type of `ListJoinedPrivateArchivedThreads`, +-- `ListPrivateArchivedThreads` and `ListPublicArchivedThreads` +data ListThreads = ListThreads + { -- | 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 + toJSON ListThreads{..} = object + [ ("threads", toJSON listThreadsThreads) + , ("members", toJSON listThreadsMembers) + , ("has_more", toJSON listThreadsHasMore) + ] + +instance FromJSON ListThreads where + parseJSON = withObject "ListThreads" $ \o -> + ListThreads <$> o .: "threads" + <*> o .: "members" + <*> o .: "has_more" + +channelMajorRoute :: ChannelRequest a -> String +channelMajorRoute c = case c of + (GetChannel chan) -> "get_chan " <> show chan + (ModifyChannel chan _) -> "mod_chan " <> show chan + (DeleteChannel chan) -> "mod_chan " <> show chan + (GetChannelMessages chan _) -> "msg " <> show chan + (GetChannelMessage (chan, _)) -> "get_msg " <> show chan + (CreateMessage chan _) -> "msg " <> show chan + (CreateMessageDetailed chan _) -> "msg " <> show chan + (CreateReaction (chan, _) _) -> "add_react " <> show chan + (DeleteOwnReaction (chan, _) _) -> "react " <> show chan + (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan + (DeleteSingleReaction (chan, _) _) -> "react " <> show chan + (GetReactions (chan, _) _ _) -> "react " <> show chan + (DeleteAllReactions (chan, _)) -> "react " <> show chan + (EditMessage (chan, _) _) -> "get_msg " <> show chan + (DeleteMessage (chan, _)) -> "get_msg " <> show chan + (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan + (EditChannelPermissions chan _ _) -> "perms " <> show chan + (GetChannelInvites chan) -> "invites " <> show chan + (CreateChannelInvite chan _) -> "invites " <> show chan + (DeleteChannelPermission chan _) -> "perms " <> show chan + (TriggerTypingIndicator chan) -> "tti " <> show chan + (GetPinnedMessages chan) -> "pins " <> show chan + (AddPinnedMessage (chan, _)) -> "pin " <> show chan + (DeletePinnedMessage (chan, _)) -> "pin " <> show chan + (GroupDMAddRecipient chan _) -> "groupdm " <> show chan + (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan + (StartThreadFromMessage chan _ _) -> "thread " <> show chan + (StartThreadNoMessage chan _) -> "thread " <> show chan + (JoinThread chan) -> "thread " <> show chan + (AddThreadMember chan _) -> "thread " <> show chan + (LeaveThread chan) -> "thread " <> show chan + (RemoveThreadMember chan _) -> "thread " <> show chan + (GetThreadMember chan _) -> "thread " <> show chan + (ListThreadMembers chan) -> "thread " <> show chan + (ListPublicArchivedThreads chan _) -> "thread " <> show chan + (ListPrivateArchivedThreads chan _) -> "thread " <> show chan + (ListJoinedPrivateArchivedThreads chan _) -> "thread " <> show chan + +cleanupEmoji :: T.Text -> T.Text +cleanupEmoji emoji = + let noAngles = T.replace "<" "" (T.replace ">" "" emoji) + byName = T.pack <$> unicodeByName (T.unpack (T.replace ":" "" emoji)) + in case (byName, T.stripPrefix ":" noAngles) of + (Just e, _) -> e + (_, Just a) -> "custom:" <> a + (_, Nothing) -> noAngles + +channels :: R.Url 'R.Https +channels = baseUrl /: "channels" + +channelJsonRequest :: ChannelRequest r -> JsonRequest +channelJsonRequest c = case c of + (GetChannel chan) -> + Get (channels /~ chan) mempty + + (ModifyChannel chan patch) -> + Patch (channels /~ chan) (pure (R.ReqBodyJson patch)) mempty + + (DeleteChannel chan) -> + 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 + + (GetChannelMessage (chan, msg)) -> + 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 + + (CreateMessageDetailed chan msgOpts) -> + let fileUpload = messageDetailedFile msgOpts + filePart = + ( case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody + "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] + ) + ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) + + payloadData = objectFromMaybes $ + [ "content" .== messageDetailedContent msgOpts + , "tts" .== messageDetailedTTS msgOpts ] ++ + [ "embeds" .=? ((createEmbed <$>) <$> messageDetailedEmbeds msgOpts) + , "allowed_mentions" .=? messageDetailedAllowedMentions msgOpts + , "message_reference" .=? messageDetailedReference msgOpts + , "components" .=? messageDetailedComponents msgOpts + , "sticker_ids" .=? messageDetailedStickerIds msgOpts + ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) + in Post (channels /~ chan /: "messages") body mempty + + (CreateReaction (chan, msgid) emoji) -> + let e = cleanupEmoji emoji + 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 + + (DeleteUserReaction (chan, msgid) uID emoji) -> + let e = cleanupEmoji emoji + 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 + + (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 + + (DeleteAllReactions (chan, msgid)) -> + Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" ) mempty + + -- copied from CreateMessageDetailed, should be outsourced to function probably + (EditMessage (chan, msg) msgOpts) -> + let fileUpload = messageDetailedFile msgOpts + filePart = + ( case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody + "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] + ) + ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) + + payloadData = objectFromMaybes $ + [ "content" .== messageDetailedContent msgOpts + , "tts" .== messageDetailedTTS msgOpts ] ++ + [ "embeds" .=? ((createEmbed <$>) <$> messageDetailedEmbeds msgOpts) + , "allowed_mentions" .=? messageDetailedAllowedMentions msgOpts + , "message_reference" .=? messageDetailedReference msgOpts + , "components" .=? messageDetailedComponents msgOpts + , "sticker_ids" .=? messageDetailedStickerIds msgOpts + ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) + in Patch (channels /~ chan /: "messages" /~ msg) body mempty + + (DeleteMessage (chan, msg)) -> + 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 + + (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 + + (CreateChannelInvite chan patch) -> + Post (channels /~ chan /: "invites") (pure (R.ReqBodyJson patch)) mempty + + (DeleteChannelPermission chan overwriteId) -> + Delete (channels /~ chan /: "permissions" /~ either unId unId overwriteId) mempty + + (TriggerTypingIndicator chan) -> + Post (channels /~ chan /: "typing") (pure R.NoReqBody) mempty + + (GetPinnedMessages chan) -> + Get (channels /~ chan /: "pins") mempty + + (AddPinnedMessage (chan, msg)) -> + Put (channels /~ chan /: "pins" /~ msg) R.NoReqBody mempty + + (DeletePinnedMessage (chan, msg)) -> + Delete (channels /~ chan /: "pins" /~ msg) mempty + + (GroupDMAddRecipient chan (GroupDMAddRecipientOpts uid nick tok)) -> + 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 + + (StartThreadFromMessage chan mid sto) -> + Post (channels /~ chan /: "messages" /~ mid /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty + + (StartThreadNoMessage chan sto) -> + Post (channels /~ chan /: "messages" /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty + + (JoinThread chan) -> + Put (channels /~ chan /: "thread-members" /: "@me") + R.NoReqBody mempty + + (AddThreadMember chan uid) -> + Put (channels /~ chan /: "thread-members" /~ uid) + R.NoReqBody mempty + + (LeaveThread chan) -> + Delete (channels /~ chan /: "thread-members" /: "@me") + mempty + + (RemoveThreadMember chan uid) -> + Delete (channels /~ chan /: "thread-members" /~ uid) + mempty + + (GetThreadMember chan uid) -> + Get (channels /~ chan /: "thread-members" /~ uid) + mempty + + (ListThreadMembers chan) -> + Get (channels /~ chan /: "thread-members") + mempty + + (ListPublicArchivedThreads chan (time, lim)) -> + 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") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListJoinedPrivateArchivedThreads chan (time, lim)) -> + Get (channels /~ chan /: "users" /: "@me" /: "threads" /: "archived" /: "private") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs new file mode 100644 index 0000000..2a52171 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Emoji + ( EmojiRequest (..), + ModifyGuildEmojiOpts (..), + parseEmojiImage, + parseStickerImage, + StickerRequest (..), + CreateGuildStickerOpts (..), + EditGuildStickerOpts (..) + ) +where + +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R + +instance Request (EmojiRequest a) where + majorRoute = emojiMajorRoute + jsonRequest = emojiJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data EmojiRequest a where + -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission. + ListGuildEmojis :: GuildId -> EmojiRequest [Emoji] + -- | 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 -> Base64Image Emoji -> EmojiRequest Emoji + -- | Requires MANAGE_EMOJIS permission + ModifyGuildEmoji :: GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji + -- | Requires MANAGE_EMOJIS permission + DeleteGuildEmoji :: GuildId -> EmojiId -> EmojiRequest () + +data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts + { modifyGuildEmojiName :: T.Text, + modifyGuildEmojiRoles :: [RoleId] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildEmojiOpts where + toJSON (ModifyGuildEmojiOpts name roles) = + object ["name" .= name, "roles" .= roles] + + +-- | @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 + (ListGuildEmojis g) -> "emoji " <> show g + (GetGuildEmoji g _) -> "emoji " <> show g + (CreateGuildEmoji g _ _) -> "emoji " <> show g + (ModifyGuildEmoji g _ _) -> "emoji " <> show g + (DeleteGuildEmoji g _) -> "emoji " <> show g + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +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 b64im) -> + Post + (guilds /~ g /: "emojis") + ( pure + ( R.ReqBodyJson + ( object + [ "name" .= name, + "image" .= b64im + -- todo , "roles" .= ... + ] + ) + ) + ) + mempty + (ModifyGuildEmoji g e o) -> + Patch + (guilds /~ g /: "emojis" /~ e) + (pure (R.ReqBodyJson o)) + mempty + (DeleteGuildEmoji g e) -> Delete (guilds /~ g /: "emojis" /~ e) mempty + +-- | @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 :: Base64Image Sticker + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildStickerOpts where + toJSON (CreateGuildStickerOpts name desc tags b64im) = + object + [ ("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, + editGuildStickerTags :: Maybe [T.Text] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON EditGuildStickerOpts where + toJSON EditGuildStickerOpts {..} = + objectFromMaybes + [ "name" .=? editGuildStickerName, + "description" .=? editGuildStickerDescription, + "tags" .=? fmap (T.intercalate ",") editGuildStickerTags + ] + +instance Request (StickerRequest a) where + majorRoute = stickerMajorRoute + jsonRequest = stickerJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +-- +-- Be warned that these are untested due to not having a spare server with +-- boosts. Functionality is at your own risk. +data StickerRequest a where + -- | Returns a sticker object for the given sticker ID. + GetSticker :: StickerId -> StickerRequest Sticker + -- | Returns the list of sticker packs available to Nitro subscribers. + ListNitroStickerPacks :: StickerRequest [StickerPack] + -- | Returns an array of sticker objects for the given guild. + ListGuildStickers :: GuildId -> StickerRequest [Sticker] + -- | Returns a sticker object for the given guild and sticker ID. + GetGuildSticker :: GuildId -> StickerId -> StickerRequest Sticker + -- | Create a new sticker for the guild. + CreateGuildSticker :: GuildId -> CreateGuildStickerOpts -> StickerRequest Sticker + -- | Modify a sticker for a guild. + ModifyGuildSticker :: GuildId -> StickerId -> EditGuildStickerOpts -> StickerRequest Sticker + -- | Delete a guild sticker + DeleteGuildSticker :: GuildId -> StickerId -> StickerRequest () + +stickerMajorRoute :: StickerRequest a -> String +stickerMajorRoute = \case + GetSticker gid -> "sticker " <> show gid + ListNitroStickerPacks -> "sticker" + ListGuildStickers gid -> "sticker " <> show gid + GetGuildSticker gid _ -> "sticker " <> show gid + CreateGuildSticker gid _ -> "sticker " <> show gid + ModifyGuildSticker gid _ _ -> "sticker " <> show gid + DeleteGuildSticker gid _ -> "sticker " <> show gid + +stickerJsonRequest :: StickerRequest a -> JsonRequest +stickerJsonRequest = \case + 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 + 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 + where + stickersGuild gid = baseUrl /: "guilds" /~ gid /: "stickers" diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs new file mode 100644 index 0000000..a0cb3aa --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Guild + ( GuildRequest(..) + , CreateGuildChannelOpts(..) + , ModifyGuildOpts(..) + , AddGuildMemberOpts(..) + , ModifyGuildMemberOpts(..) + , GuildMembersTiming(..) + , CreateGuildBanOpts(..) + , ModifyGuildRoleOpts(..) + , CreateGuildIntegrationOpts(..) + , ModifyGuildIntegrationOpts(..) + ) where + + +import Data.Aeson +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R +import qualified Data.Text as T + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Data.Default (Default(..)) + +instance Request (GuildRequest a) where + majorRoute = guildMajorRoute + jsonRequest = guildJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data GuildRequest a where + -- -- Creating a guild with the API is annoying. Do it manually. + -- -- https://discord.com/developers/docs/resources/guild#create-guild + + -- | Returns the new 'Guild' object for the given id + GetGuild :: GuildId -> GuildRequest Guild + -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a + -- Guild Update 'Event'. + ModifyGuild :: GuildId -> ModifyGuildOpts -> GuildRequest Guild + -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'. + DeleteGuild :: GuildId -> GuildRequest () + -- | Returns a list of guild 'Channel' objects + GetGuildChannels :: GuildId -> GuildRequest [Channel] + -- | Create a new 'Channel' object for the guild. Requires 'MANAGE_CHANNELS' + -- permission. Returns the new 'Channel' object on success. Fires a Channel Create + -- 'Event' + CreateGuildChannel :: GuildId -> T.Text -> [Overwrite] -> CreateGuildChannelOpts -> GuildRequest Channel + -- | Modify the positions of a set of channel objects for the guild. Requires + -- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel' + -- objects on success. Fires multiple Channel Update 'Event's. + ModifyGuildChannelPositions :: GuildId -> [(ChannelId,Int)] -> GuildRequest [Channel] + -- | Returns a guild 'Member' object for the specified user + GetGuildMember :: GuildId -> UserId -> GuildRequest GuildMember + -- | Returns a list of guild 'Member' objects that are members of the guild. + ListGuildMembers :: GuildId -> GuildMembersTiming -> GuildRequest [GuildMember] + -- | Adds a user to the guild, provided you have a valid oauth2 access token + -- for the user with the guilds.join scope. Returns the guild 'Member' as the body. + -- Fires a Guild Member Add 'Event'. Requires the bot to have the + -- CREATE_INSTANT_INVITE permission. + AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts + -> GuildRequest () + -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. + ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember + -- | Modify the nickname of the current user + ModifyCurrentUserNick :: GuildId -> T.Text -> GuildRequest () + -- | Add a member to a guild role. Requires 'MANAGE_ROLES' permission. + AddGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest () + -- | Remove a member from a guild role. Requires 'MANAGE_ROLES' permission. + RemoveGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest () + -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a + -- Guild Member Remove 'Event'. + RemoveGuildMember :: GuildId -> UserId -> GuildRequest () + -- | Returns a list of 'Ban' objects for users that are banned from this guild. Requires the + -- 'BAN_MEMBERS' permission + GetGuildBans :: GuildId -> GuildRequest [GuildBan] + -- | Returns a 'Ban' object for the user banned from this guild. Requires the + -- 'BAN_MEMBERS' permission + GetGuildBan :: GuildId -> UserId -> GuildRequest GuildBan + -- | Create a guild ban, and optionally Delete previous messages sent by the banned + -- user. Requires the 'BAN_MEMBERS' permission. Fires a Guild Ban Add 'Event'. + CreateGuildBan :: GuildId -> UserId -> CreateGuildBanOpts -> GuildRequest () + -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions. + -- Fires a Guild Ban Remove 'Event'. + RemoveGuildBan :: GuildId -> UserId -> GuildRequest () + -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES' + -- permission + GetGuildRoles :: GuildId -> GuildRequest [Role] + -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission. + -- Returns the new role object on success. Fires a Guild Role Create 'Event'. + CreateGuildRole :: GuildId -> ModifyGuildRoleOpts -> GuildRequest Role + -- | Modify the positions of a set of role objects for the guild. Requires the + -- 'MANAGE_ROLES' permission. Returns a list of all of the guild's 'Role' objects + -- on success. Fires multiple Guild Role Update 'Event's. + ModifyGuildRolePositions :: GuildId -> [(RoleId, Integer)] -> GuildRequest [Role] + -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the + -- updated 'Role' on success. Fires a Guild Role Update 'Event's. + ModifyGuildRole :: GuildId -> RoleId -> ModifyGuildRoleOpts -> GuildRequest Role + -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role + -- Delete 'Event'. + DeleteGuildRole :: GuildId -> RoleId -> GuildRequest () + -- | Returns an object with one 'pruned' key indicating the number of members + -- that would be removed in a prune operation. Requires the 'KICK_MEMBERS' + -- permission. + GetGuildPruneCount :: GuildId -> Integer -> GuildRequest Object + -- | Begin a prune operation. Requires the 'KICK_MEMBERS' permission. Returns an + -- object with one 'pruned' key indicating the number of members that were removed + -- in the prune operation. Fires multiple Guild Member Remove 'Events'. + BeginGuildPrune :: GuildId -> Integer -> GuildRequest Object + -- | Returns a list of 'VoiceRegion' objects for the guild. Unlike the similar /voice + -- route, this returns VIP servers when the guild is VIP-enabled. + GetGuildVoiceRegions :: GuildId -> GuildRequest [VoiceRegion] + -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD' + -- permission. + GetGuildInvites :: GuildId -> GuildRequest [Invite] + -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD' + -- permission. + GetGuildIntegrations :: GuildId -> GuildRequest [Integration] + -- | Attach an 'Integration' object from the current user to the guild. Requires the + -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + CreateGuildIntegration :: GuildId -> IntegrationId -> CreateGuildIntegrationOpts -> GuildRequest () + -- | Modify the behavior and settings of a 'Integration' object for the guild. + -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + ModifyGuildIntegration :: GuildId -> IntegrationId -> ModifyGuildIntegrationOpts + -> GuildRequest () + -- | Delete the attached 'Integration' object for the guild. Requires the + -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + DeleteGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () + -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. + SyncGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () + -- | Returns the 'GuildWidget' object. Requires the 'MANAGE_GUILD' permission. + GetGuildWidget :: GuildId -> GuildRequest GuildWidget + -- | Modify a 'GuildWidget' object for the guild. All attributes may be passed in with + -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated + -- 'GuildWidget' object. + ModifyGuildWidget :: GuildId -> GuildWidget -> GuildRequest GuildWidget + -- | Vanity URL + GetGuildVanityURL :: GuildId -> GuildRequest T.Text + +-- | Options for `ModifyGuildIntegration` +data ModifyGuildIntegrationOpts = ModifyGuildIntegrationOpts + { modifyGuildIntegrationOptsExpireBehavior :: Integer + , modifyGuildIntegrationOptsExpireGraceSeconds :: Integer + , modifyGuildIntegrationOptsEmoticonsEnabled :: Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildIntegrationOpts where + toJSON ModifyGuildIntegrationOpts{..} = objectFromMaybes + [ "expire_grace_period" .== modifyGuildIntegrationOptsExpireGraceSeconds + , "expire_behavior" .== modifyGuildIntegrationOptsExpireBehavior + , "enable_emoticons" .== modifyGuildIntegrationOptsEmoticonsEnabled ] + +-- | Options for `CreateGuildIntegration` +newtype CreateGuildIntegrationOpts = CreateGuildIntegrationOpts + { createGuildIntegrationOptsType :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildIntegrationOpts where + toJSON CreateGuildIntegrationOpts{..} = objectFromMaybes + ["type" .== createGuildIntegrationOptsType] + +-- | Options for `CreateGuildBan` +data CreateGuildBanOpts = CreateGuildBanOpts + { createGuildBanOptsDeleteLastNMessages :: Maybe Int + , createGuildBanOptsReason :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildBanOpts where + toJSON CreateGuildBanOpts{..} = objectFromMaybes + [ "delete_message_days" + .=? createGuildBanOptsDeleteLastNMessages + , "reason" .=? createGuildBanOptsReason] + +-- | Options for `ModifyGuildRole` +data ModifyGuildRoleOpts = ModifyGuildRoleOpts + { modifyGuildRoleOptsName :: Maybe T.Text + , modifyGuildRoleOptsPermissions :: Maybe RolePermissions + , modifyGuildRoleOptsColor :: Maybe DiscordColor + , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool + , modifyGuildRoleOptsMentionable :: Maybe Bool + , modifyGuildRoleOptsIcon :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildRoleOpts where + toJSON ModifyGuildRoleOpts{..} = objectFromMaybes + ["name" .=? modifyGuildRoleOptsName, + "permissions" .=? modifyGuildRoleOptsPermissions, + "color" .=? modifyGuildRoleOptsColor, + "hoist" .=? modifyGuildRoleOptsSeparateSidebar, + "mentionable" .=? modifyGuildRoleOptsMentionable, + "icon" .=? modifyGuildRoleOptsIcon] + +-- | Options for `AddGuildMember` +data AddGuildMemberOpts = AddGuildMemberOpts + { addGuildMemberOptsAccessToken :: T.Text + , addGuildMemberOptsNickname :: Maybe T.Text + , addGuildMemberOptsRoles :: Maybe [RoleId] + , addGuildMemberOptsIsMuted :: Maybe Bool + , addGuildMemberOptsIsDeafened :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON AddGuildMemberOpts where + toJSON AddGuildMemberOpts{..} = objectFromMaybes + ["access_token" .== addGuildMemberOptsAccessToken, + "nick" .=? addGuildMemberOptsNickname, + "roles" .=? addGuildMemberOptsRoles, + "mute" .=? addGuildMemberOptsIsMuted, + "deaf" .=? addGuildMemberOptsIsDeafened] + +-- | Options for `ModifyGuildMember` +data ModifyGuildMemberOpts = ModifyGuildMemberOpts + { modifyGuildMemberOptsNickname :: Maybe T.Text + , modifyGuildMemberOptsRoles :: Maybe [RoleId] + , modifyGuildMemberOptsIsMuted :: Maybe Bool + , modifyGuildMemberOptsIsDeafened :: Maybe Bool + , modifyGuildMemberOptsMoveToChannel :: Maybe ChannelId + , modifyGuildMemberOptsTimeoutUntil :: Maybe (Maybe UTCTime) -- ^ If `Just Nothing`, the timeout will be removed. + } deriving (Show, Read, Eq, Ord) + +instance Default ModifyGuildMemberOpts where + def = ModifyGuildMemberOpts Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON ModifyGuildMemberOpts where + toJSON ModifyGuildMemberOpts{..} = objectFromMaybes + ["nick" .=? modifyGuildMemberOptsNickname, + "roles" .=? modifyGuildMemberOptsRoles, + "mute" .=? modifyGuildMemberOptsIsMuted, + "deaf" .=? modifyGuildMemberOptsIsDeafened, + "channel_id" .=? modifyGuildMemberOptsMoveToChannel, + "communication_disabled_until" .=? 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 = objectFromMaybes optsJSON + where + optsJSON = case opts of + CreateGuildChannelOptsText{..} -> + ["name" .== String name + ,"type" .== Number 0 + ,"permission_overwrites" .== perms + ,"topic" .=? createGuildChannelOptsTopic + ,"rate_limit_per_user" .=? createGuildChannelOptsUserMessageRateDelay + ,"nsfw" .=? createGuildChannelOptsIsNSFW + ,"parent_id" .=? createGuildChannelOptsCategoryId] + CreateGuildChannelOptsVoice{..} -> + ["name" .== String name + ,"type" .== Number 2 + ,"permission_overwrites" .== perms + ,"bitrate" .=? createGuildChannelOptsBitrate + ,"user_limit" .=? createGuildChannelOptsMaxUsers + ,"parent_id" .=? createGuildChannelOptsCategoryId] + CreateGuildChannelOptsCategory -> + ["name" .== String name + ,"type" .== Number 4 + ,"permission_overwrites" .== perms] + + +-- | Options for `ModifyGuild` +-- +-- See <https://discord.com/developers/docs/resources/guild#modify-guild> +data ModifyGuildOpts = ModifyGuildOpts + { modifyGuildOptsName :: Maybe T.Text + , modifyGuildOptsAFKChannelId :: Maybe ChannelId + , modifyGuildOptsIcon :: Maybe T.Text + , modifyGuildOptsOwnerId :: Maybe UserId + -- Region + -- VerificationLevel + -- DefaultMessageNotification + -- ExplicitContentFilter + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildOpts where + toJSON ModifyGuildOpts{..} = objectFromMaybes + ["name" .=? modifyGuildOptsName, + "afk_channel_id" .=? modifyGuildOptsAFKChannelId, + "icon" .=? modifyGuildOptsIcon, + "owner_id" .=? modifyGuildOptsOwnerId] + +data GuildMembersTiming = GuildMembersTiming + { guildMembersTimingLimit :: Maybe Int + , guildMembersTimingAfter :: Maybe UserId + } deriving (Show, Read, Eq, Ord) + +guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https +guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) = + let limit = case mLimit of + Nothing -> mempty + Just lim -> "limit" R.=: lim + after = case mAfter of + Nothing -> mempty + Just aft -> "after" R.=: show aft + in limit <> after + +guildMajorRoute :: GuildRequest a -> String +guildMajorRoute c = case c of + (GetGuild g) -> "guild " <> show g + (ModifyGuild g _) -> "guild " <> show g + (DeleteGuild g) -> "guild " <> show g + (GetGuildChannels g) -> "guild_chan " <> show g + (CreateGuildChannel g _ _ _) -> "guild_chan " <> show g + (ModifyGuildChannelPositions g _) -> "guild_chan " <> show g + (GetGuildMember g _) -> "guild_memb " <> show g + (ListGuildMembers g _) -> "guild_membs " <> show g + (AddGuildMember g _ _) -> "guild_membs " <> show g + (ModifyGuildMember g _ _) -> "guild_membs " <> show g + (ModifyCurrentUserNick g _) -> "guild_membs " <> show g + (AddGuildMemberRole g _ _) -> "guild_membs " <> show g + (RemoveGuildMemberRole g _ _) -> "guild_membs " <> show g + (RemoveGuildMember g _) -> "guild_membs " <> show g + (GetGuildBan g _) -> "guild_bans " <> show g + (GetGuildBans g) -> "guild_bans " <> show g + (CreateGuildBan g _ _) -> "guild_ban " <> show g + (RemoveGuildBan g _) -> "guild_ban " <> show g + (GetGuildRoles g) -> "guild_roles " <> show g + (CreateGuildRole g _) -> "guild_roles " <> show g + (ModifyGuildRolePositions g _) -> "guild_roles " <> show g + (ModifyGuildRole g _ _) -> "guild_role " <> show g + (DeleteGuildRole g _) -> "guild_role " <> show g + (GetGuildPruneCount g _) -> "guild_prune " <> show g + (BeginGuildPrune g _) -> "guild_prune " <> show g + (GetGuildVoiceRegions g) -> "guild_voice " <> show g + (GetGuildInvites g) -> "guild_invit " <> show g + (GetGuildIntegrations g) -> "guild_integ " <> show g + (CreateGuildIntegration g _ _) -> "guild_integ " <> show g + (ModifyGuildIntegration g _ _) -> "guild_intgr " <> show g + (DeleteGuildIntegration g _) -> "guild_intgr " <> show g + (SyncGuildIntegration g _) -> "guild_sync " <> show g + (GetGuildWidget g) -> "guild_widget " <> show g + (ModifyGuildWidget g _) -> "guild_widget " <> show g + (GetGuildVanityURL g) -> "guild " <> show g + + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +guildJsonRequest :: GuildRequest r -> JsonRequest +guildJsonRequest c = case c of + (GetGuild guild) -> + Get (guilds /~ guild) mempty + + (ModifyGuild guild patch) -> + Patch (guilds /~ guild) (pure (R.ReqBodyJson patch)) mempty + + (DeleteGuild guild) -> + Delete (guilds /~ guild) mempty + + (GetGuildChannels guild) -> + Get (guilds /~ guild /: "channels") mempty + + (CreateGuildChannel guild name perms patch) -> + 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 + + (GetGuildMember guild member) -> + Get (guilds /~ guild /: "members" /~ member) mempty + + (ListGuildMembers guild range) -> + Get (guilds /~ guild /: "members") (guildMembersTimingToQuery range) + + (AddGuildMember guild user patch) -> + Put (guilds /~ guild /: "members" /~ user) (R.ReqBodyJson patch) mempty + + (ModifyGuildMember guild member patch) -> + 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 + + (AddGuildMemberRole guild user role) -> + let body = R.ReqBodyJson (object []) + in Put (guilds /~ guild /: "members" /~ user /: "roles" /~ role) body mempty + + (RemoveGuildMemberRole guild user role) -> + Delete (guilds /~ guild /: "members" /~ user /: "roles" /~ role) mempty + + (RemoveGuildMember guild user) -> + Delete (guilds /~ guild /: "members" /~ user) mempty + + (GetGuildBan guild user) -> Get (guilds /~ guild /: "bans" /~ user) mempty + + (GetGuildBans guild) -> Get (guilds /~ guild /: "bans") mempty + + (CreateGuildBan guild user patch) -> + Put (guilds /~ guild /: "bans" /~ user) (R.ReqBodyJson patch) mempty + + (RemoveGuildBan guild ban) -> + Delete (guilds /~ guild /: "bans" /~ ban) mempty + + (GetGuildRoles guild) -> + Get (guilds /~ guild /: "roles") mempty + + (CreateGuildRole guild patch) -> + 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 + + (ModifyGuildRole guild role patch) -> + Patch (guilds /~ guild /: "roles" /~ role) (pure (R.ReqBodyJson patch)) mempty + + (DeleteGuildRole guild role) -> + Delete (guilds /~ guild /: "roles" /~ role) mempty + + (GetGuildPruneCount guild days) -> + Get (guilds /~ guild /: "prune") ("days" R.=: days) + + (BeginGuildPrune guild days) -> + Post (guilds /~ guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) + + (GetGuildVoiceRegions guild) -> + Get (guilds /~ guild /: "regions") mempty + + (GetGuildInvites guild) -> + Get (guilds /~ guild /: "invites") mempty + + (GetGuildIntegrations guild) -> + 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 + + (ModifyGuildIntegration guild iid patch) -> + let body = pure (R.ReqBodyJson patch) + in Patch (guilds /~ guild /: "integrations" /~ iid) body mempty + + (DeleteGuildIntegration guild integ) -> + Delete (guilds /~ guild /: "integrations" /~ integ) mempty + + (SyncGuildIntegration guild integ) -> + Post (guilds /~ guild /: "integrations" /~ integ) (pure R.NoReqBody) mempty + + (GetGuildWidget guild) -> + Get (guilds /~ guild /: "integrations") mempty + + (ModifyGuildWidget guild patch) -> + Patch (guilds /~ guild /: "widget") (pure (R.ReqBodyJson patch)) mempty + + (GetGuildVanityURL guild) -> + Get (guilds /~ guild /: "vanity-url") mempty + diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/HTTP.hs b/deps/discord-haskell/src/Discord/Internal/Rest/HTTP.hs new file mode 100644 index 0000000..f9c0341 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/HTTP.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Provide HTTP primitives +module Discord.Internal.Rest.HTTP + ( restLoop + , Request(..) + , JsonRequest(..) + , RestCallInternalException(..) + ) where + +import Prelude hiding (log) + +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent (threadDelay) +import Control.Exception.Safe (try) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.Ix (inRange) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) +import qualified Network.HTTP.Req as R +import qualified Data.Map.Strict as M + +import Discord.Internal.Types +import Discord.Internal.Rest.Prelude + +-- | 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 + where + loop ratelocker = do + threadDelay (40 * 1000) + (route, request, thread) <- readChan urls + curtime <- getPOSIXTime + case compareRate ratelocker route curtime of + Locked -> do writeChan urls (route, request, thread) + loop ratelocker + Available -> do let action = compileRequest auth request + reqIO <- try $ restIOtoIO (tryRequest log action) + case reqIO :: Either R.HttpException (RequestResponse, Timeout) of + Left e -> do + writeChan log ("rest - http exception " <> T.pack (show e)) + putMVar thread (Left (RestCallInternalHttpException e)) + loop ratelocker + Right (resp, retry) -> do + case resp of + -- decode "[]" == () for expected empty calls + ResponseByteString "" -> putMVar thread (Right "[]") + ResponseByteString bs -> putMVar thread (Right bs) + ResponseErrorCode e s b -> + putMVar thread (Left (RestCallInternalErrorCode e s b)) + ResponseTryAgain -> writeChan urls (route, request, thread) + case retry of + GlobalWait i -> do + writeChan log ("rest - GLOBAL WAIT LIMIT: " + <> T.pack (show ((i - curtime) * 1000))) + threadDelay $ round ((i - curtime + 0.1) * 1000) + loop ratelocker + PathWait i -> loop $ M.insert route i (removeAllExpire ratelocker curtime) + NoLimit -> loop ratelocker + +data RateLimited = Available | Locked + +compareRate :: M.Map String POSIXTime -> String -> POSIXTime -> RateLimited +compareRate ratelocker route curtime = + case M.lookup route ratelocker of + Just unlockTime -> if curtime < unlockTime then Locked else Available + Nothing -> Available + +removeAllExpire :: M.Map String POSIXTime -> POSIXTime -> M.Map String POSIXTime +removeAllExpire ratelocker curtime = + if M.size ratelocker > 100 then M.filter (> curtime) ratelocker + else ratelocker + +data RequestResponse = ResponseTryAgain + | ResponseByteString BL.ByteString + | ResponseErrorCode Int B.ByteString B.ByteString + deriving (Show) + +data Timeout = GlobalWait POSIXTime + | PathWait POSIXTime + | NoLimit + +tryRequest :: Chan T.Text -> RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout) +tryRequest _log action = do + resp <- action + now <- liftIO getPOSIXTime + let body = R.responseBody resp + code = R.responseStatusCode resp + status = R.responseStatusMessage resp + global = (Just ("true" :: String) ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global" + remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining" :: Integer + reset = withDelta . fromMaybe 10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset-After" + + withDelta :: Double -> POSIXTime + withDelta dt = now + fromRational (toRational dt) + + if | code == 429 -> pure (ResponseTryAgain, if global then GlobalWait reset + else PathWait reset) + | code `elem` [500,502] -> pure (ResponseTryAgain, NoLimit) + | inRange (200,299) code -> pure ( ResponseByteString body + , if remain > 0 then NoLimit else PathWait reset ) + | inRange (400,499) code -> pure (ResponseErrorCode code status (BL.toStrict body) + , if remain > 0 then NoLimit else PathWait reset ) + | otherwise -> pure (ResponseErrorCode code status (BL.toStrict body), NoLimit) + +readMaybeBS :: Read a => B.ByteString -> Maybe a +readMaybeBS = readMaybe . T.unpack . TE.decodeUtf8 + +compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse +compileRequest auth request = action + where + authopt = authHeader auth <> R.header "X-RateLimit-Precision" "millisecond" + + action = case request of + (Delete url opts) -> R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts) + (Get url opts) -> R.req R.GET url R.NoReqBody R.lbsResponse (authopt <> opts) + (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) + (Patch url body opts) -> do b <- body + R.req R.PATCH url b R.lbsResponse (authopt <> opts) + (Post url body opts) -> do b <- body + R.req R.POST url b R.lbsResponse (authopt <> opts) diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Interactions.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Interactions.hs new file mode 100644 index 0000000..44e41d1 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Interactions.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +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 qualified Network.HTTP.Req as R + +-- | 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 + jsonRequest = interactionResponseJsonRequest + majorRoute = interactionResponseMajorRoute + +interactionResponseMajorRoute :: InteractionResponseRequest a -> String +interactionResponseMajorRoute a = case a of + (CreateInteractionResponse iid _ _) -> "intresp " <> show iid + (GetOriginalInteractionResponse aid _) -> "intresp " <> show aid + (EditOriginalInteractionResponse aid _ _) -> "intresp " <> show aid + (DeleteOriginalInteractionResponse aid _) -> "intresp " <> show aid + (CreateFollowupInteractionMessage iid _ _) -> "intrespf " <> show iid + (GetFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + (EditFollowupInteractionMessage aid _ _ _) -> "intrespf " <> show aid + (DeleteFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + +interaction :: ApplicationId -> InteractionToken -> R.Url 'R.Https +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 /~ it /: "callback") (convert i) mempty + (GetOriginalInteractionResponse aid it) -> + Get (interaction aid it /: "@original") mempty + (EditOriginalInteractionResponse aid it i) -> + Patch (interaction aid it /: "@original") (convertIRM i) mempty + (DeleteOriginalInteractionResponse aid it) -> + Delete (interaction aid it /: "@original") mempty + (CreateFollowupInteractionMessage aid it i) -> + Post (baseUrl /: "webhooks" /~ aid /~ it) (convertIRM i) mempty + (GetFollowupInteractionMessage aid it mid) -> + Get (interaction aid it /~ mid) mempty + (EditFollowupInteractionMessage aid it mid i) -> + Patch (interaction aid it /~ mid) (convert i) mempty + (DeleteFollowupInteractionMessage aid it mid) -> + 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) + convert ir@(InteractionResponseUpdateMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir = R.reqBodyMultipart [partBS "payload_json" $ BL.toStrict $ encode ir] + convertIRM :: InteractionResponseMessage -> RestIO R.ReqBodyMultipart + convertIRM irm = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode irm) : convert' irm) + convert' :: InteractionResponseMessage -> [PartM IO] + convert' InteractionResponseMessage {..} = case interactionResponseMessageEmbeds of + Nothing -> [] + Just f -> (maybeEmbed . Just) =<< f diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Invite.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Invite.hs new file mode 100644 index 0000000..79b4aa5 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Invite.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Invite + ( InviteRequest(..) + ) where + +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R +import qualified Data.Text as T + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (InviteRequest a) where + majorRoute = inviteMajorRoute + jsonRequest = inviteJsonRequest + + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data InviteRequest a where + -- | Get invite for given code + GetInvite :: T.Text -> InviteRequest Invite + -- | Delete invite by code + DeleteInvite :: T.Text -> InviteRequest Invite + +inviteMajorRoute :: InviteRequest a -> String +inviteMajorRoute c = case c of + (GetInvite _) -> "invite " + (DeleteInvite _) -> "invite " + +invite :: R.Url 'R.Https +invite = baseUrl /: "invites" + +inviteJsonRequest :: InviteRequest r -> JsonRequest +inviteJsonRequest c = case c of + (GetInvite g) -> Get (invite R./: g) mempty + (DeleteInvite g) -> Delete (invite R./: g) mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Prelude.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Prelude.hs new file mode 100644 index 0000000..4b7d825 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Prelude.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | Utility and base types and functions for the Discord Rest API +module Discord.Internal.Rest.Prelude where + +import Prelude hiding (log) +import Control.Exception.Safe (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.String (IsString(fromString)) +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 + +import Paths_discord_haskell (version) +import Data.Version (showVersion) + +-- | The api version to use. +apiVersion :: T.Text +apiVersion = "10" + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discord.com" R./: "api" R./: apiVersion' + where apiVersion' = "v" <> apiVersion + +-- | Discord requires HTTP headers for authentication. +authHeader :: Auth -> R.Option 'R.Https +authHeader auth = + R.header "Authorization" (TE.encodeUtf8 (authToken auth)) + <> R.header "User-Agent" agent + where + -- | https://discord.com/developers/docs/reference#user-agent + -- Second place where the library version is noted + agent = fromString $ "DiscordBot (https://github.com/discord-haskell/discord-haskell, " <> showVersion version <> ")" + +-- 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 +data JsonRequest where + Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Put :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest + Patch :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + Post :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + +class Request a where + -- | used for putting a request into a rate limit bucket + -- https://discord.com/developers/docs/topics/rate-limits#rate-limits + majorRoute :: a -> String + + -- | build a JSON http request + jsonRequest :: a -> JsonRequest + +-- | Same Monad as IO. Overwrite Req settings +newtype RestIO a = RestIO { restIOtoIO :: IO a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance R.MonadHttp RestIO where + -- | Throw actual exceptions + handleHttpException = liftIO . throwIO + -- | Don't throw exceptions on http error codes like 404 + getHttpConfig = pure $ R.defaultHttpConfig { R.httpConfigCheckResponse = \_ _ _ -> Nothing } diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/ScheduledEvents.hs b/deps/discord-haskell/src/Discord/Internal/Rest/ScheduledEvents.hs new file mode 100644 index 0000000..bb35d12 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/ScheduledEvents.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Scheduled Event API +module Discord.Internal.Rest.ScheduledEvents + ( ScheduledEventRequest(..) + ) where +import Data.Aeson ( ToJSON(toJSON) ) +import Discord.Internal.Rest.Prelude ( JsonRequest(..) + , Request + ( jsonRequest + , majorRoute + ) + , baseUrl + ) +import Discord.Internal.Types.Prelude ( GuildId + , ScheduledEventId + ) +import Discord.Internal.Types.ScheduledEvents + ( CreateScheduledEventData + , ModifyScheduledEventData + , ScheduledEvent + , ScheduledEventUser + ) +import qualified Network.HTTP.Req as R +import Network.HTTP.Req ( (/:), (/~) ) + +-- | Data constructor for requests. +-- See <https://discord.com/developers/docs/resources/guild-scheduled-event> +data ScheduledEventRequest a where + -- | Gets all the Scheduled Events of a Guild + ListScheduledEvents ::GuildId + -> ScheduledEventRequest [ScheduledEvent] + -- | Creates a new ScheduledEvent + CreateScheduledEvent ::GuildId + -> CreateScheduledEventData + -> ScheduledEventRequest ScheduledEvent + -- | Gets the information about an Event + GetScheduledEvent ::GuildId + -> ScheduledEventId + -> ScheduledEventRequest ScheduledEvent + -- | Modifies a Scheduled Event's information + ModifyScheduledEvent ::GuildId + -> ScheduledEventId + -> ModifyScheduledEventData + -> ScheduledEventRequest ScheduledEvent + -- | Delete a ScheduledEvent + DeleteScheduledEvent ::GuildId + -> ScheduledEventId + -> ScheduledEventRequest () + -- | Gets the Users that subscribed to the event + GetScheduledEventUsers ::GuildId + -> ScheduledEventId + -> ScheduledEventRequest [ScheduledEventUser] + +sevEndpoint :: GuildId -> R.Url 'R.Https +sevEndpoint gid = baseUrl /: "guilds" /~ gid /: "scheduled-events" + +instance Request (ScheduledEventRequest a) where + majorRoute = const "scheduledEvent" + jsonRequest rq = case rq of + ListScheduledEvents gid -> Get (sevEndpoint gid) mempty + GetScheduledEvent gid ev -> Get (sevEndpoint gid /~ ev) mempty + CreateScheduledEvent gid ev -> + Post (sevEndpoint gid) (pure $ R.ReqBodyJson $ toJSON ev) mempty + ModifyScheduledEvent gid evi ev -> Patch + (sevEndpoint gid /~ evi) + (pure $ R.ReqBodyJson $ toJSON ev) + mempty + DeleteScheduledEvent gid evi -> Delete (sevEndpoint gid /~ evi) mempty + GetScheduledEventUsers gid evi -> + Get (sevEndpoint gid /~ evi /: "users") mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/User.hs b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs new file mode 100644 index 0000000..28c0505 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.User + ( UserRequest(..) + , parseAvatarImage + ) where + + +import Data.Aeson +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.Base64 as B64 + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (UserRequest a) where + majorRoute = userMajorRoute + jsonRequest = userJsonRequest + + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data UserRequest a where + -- | Returns the 'User' object of the requester's account. For OAuth2, this requires + -- the identify scope, which will return the object without an email, and optionally + -- the email scope, which returns the object with an email. + GetCurrentUser :: UserRequest User + -- | Returns a 'User' for a given user ID + GetUser :: UserId -> UserRequest User + -- | Modify user's username & avatar pic + 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] + -- | Leave a guild. + LeaveGuild :: GuildId -> UserRequest () + -- | Returns a list of DM 'Channel' objects + GetUserDMs :: UserRequest [Channel] + -- | Create a new DM channel with a user. Returns a DM 'Channel' object. + CreateDM :: UserId -> UserRequest Channel + + GetUserConnections :: UserRequest [ConnectionObject] + +-- | @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 + (GetCurrentUser) -> "me " + (GetUser _) -> "user " + (ModifyCurrentUser _ _) -> "modify_user " + (GetCurrentUserGuilds) -> "get_user_guilds " + (LeaveGuild g) -> "leave_guild " <> show g + (GetUserDMs) -> "get_dms " + (CreateDM _) -> "make_dm " + (GetUserConnections) -> "connections " + +users :: R.Url 'R.Https +users = baseUrl /: "users" + +userJsonRequest :: UserRequest r -> JsonRequest +userJsonRequest c = case c of + (GetCurrentUser) -> Get (users /: "@me") mempty + + (GetUser user) -> Get (users /~ user ) mempty + + (ModifyCurrentUser name b64im) -> + Patch (users /: "@me") (pure (R.ReqBodyJson (object [ "username" .= name + , "avatar" .= b64im ]))) mempty + + (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty + + (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" /~ guild) mempty + + (GetUserDMs) -> Get (users /: "@me" /: "channels") mempty + + (CreateDM user) -> + let body = R.ReqBodyJson $ object ["recipient_id" .= user] + in Post (users /: "@me" /: "channels") (pure body) mempty + + (GetUserConnections) -> + Get (users /: "@me" /: "connections") mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Voice.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Voice.hs new file mode 100644 index 0000000..9966aea --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Voice.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Voice API interactions +module Discord.Internal.Rest.Voice + ( VoiceRequest(..) + ) where + + +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (VoiceRequest a) where + majorRoute = voiceMajorRoute + jsonRequest = voiceJsonRequest + +-- | Data constructor for requests +data VoiceRequest a where + -- | List all available 'VoiceRegion's. + ListVoiceRegions :: VoiceRequest [VoiceRegion] + +voiceMajorRoute :: VoiceRequest a -> String +voiceMajorRoute c = case c of + (ListVoiceRegions) -> "whatever " + +voices :: R.Url 'R.Https +voices = baseUrl /: "voice" + +voiceJsonRequest :: VoiceRequest r -> JsonRequest +voiceJsonRequest c = case c of + (ListVoiceRegions) -> Get (voices /: "regions") mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs new file mode 100644 index 0000000..7b4a545 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Webhook API interactions +module Discord.Internal.Rest.Webhook + ( CreateWebhookOpts(..) + , ExecuteWebhookWithTokenOpts(..) + , ModifyWebhookOpts(..) + , WebhookContent(..) + , WebhookRequest(..) + ) where + +import Data.Aeson +import qualified Data.Text as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import Network.HTTP.Client.MultipartFormData (partBS, partFileRequestBody) + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (WebhookRequest a) where + majorRoute = webhookMajorRoute + jsonRequest = webhookJsonRequest + +-- | Data constructors for webhook requests. +data WebhookRequest a where + -- | 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 + , modifyWebhookOptsChannelId :: Maybe ChannelId + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyWebhookOpts where + toJSON ModifyWebhookOpts{..} = objectFromMaybes + ["channel_id" .=? modifyWebhookOptsChannelId, + "name" .=? modifyWebhookOptsName, + "avatar" .=? modifyWebhookOptsAvatar ] + +-- | Options for `CreateWebhook` +data CreateWebhookOpts = CreateWebhookOpts + { createWebhookOptsName :: T.Text + , createWebhookOptsAvatar :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateWebhookOpts where + toJSON CreateWebhookOpts{..} = objectFromMaybes + ["name" .== createWebhookOptsName, + "avatar" .=? 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] + deriving (Show, Read, Eq, Ord) + +webhookContentJson :: WebhookContent -> [(AesonKey, Value)] +webhookContentJson c = case c of + WebhookContentText t -> [("content", toJSON t)] + WebhookContentFile _ _ -> [] + WebhookContentEmbeds e -> [("embeds", toJSON (createEmbed <$> e))] + +instance ToJSON ExecuteWebhookWithTokenOpts where + toJSON ExecuteWebhookWithTokenOpts{..} = objectFromMaybes $ + ["username" .=? executeWebhookWithTokenOptsUsername] + <> fmap Just (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 _) -> "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 + + (GetChannelWebhooks c) -> + Get (baseUrl /: "channels" /~ c /: "webhooks") mempty + + (GetGuildWebhooks g) -> + Get (baseUrl /: "guilds" /~ g /: "webhooks") mempty + + (GetWebhook w t) -> + Get (baseUrl /: "webhooks" /~ w /? t) mempty + + (ModifyWebhook w t p) -> + Patch (baseUrl /: "webhooks" /~ w /? t) (pure (R.ReqBodyJson p)) mempty + + (DeleteWebhook w t) -> + Delete (baseUrl /: "webhooks" /~ w /? t) mempty + + (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 + WebhookContentText _ -> + let body = pure (R.ReqBodyJson o) + in Post (baseUrl /: "webhooks" /~ w /~ tok) body mempty + WebhookContentEmbeds embeds -> + let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed{..} = [(n,c) | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png", createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png", createEmbedImage) + , ("footer.png", createEmbedFooterIcon) ]] + parts = map mkPart (concatMap uploads embeds) + partsJson = [partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["embed" .= createEmbed e] | e <- embeds] + body = R.reqBodyMultipart (partsJson ++ parts) + in Post (baseUrl /: "webhooks" /~ w /: 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/deps/discord-haskell/src/Discord/Internal/Types.hs b/deps/discord-haskell/src/Discord/Internal/Types.hs new file mode 100644 index 0000000..0dac11c --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types.hs @@ -0,0 +1,74 @@ +-- | Re-export ALL the internal type modules. Hiding is in Discord.Types +module Discord.Internal.Types + ( module Discord.Internal.Types.Prelude, + module Discord.Internal.Types.Channel, + module Discord.Internal.Types.Color, + module Discord.Internal.Types.Events, + module Discord.Internal.Types.Gateway, + module Discord.Internal.Types.Guild, + module Discord.Internal.Types.User, + module Discord.Internal.Types.Embed, + module Discord.Internal.Types.Components, + module Discord.Internal.Types.Emoji, + module Discord.Internal.Types.RolePermissions, + module Data.Aeson, + module Data.Time.Clock, + userFacingEvent, + ) +where + +import Data.Aeson (Object, ToJSON (toJSON)) +import Data.Time.Clock (UTCTime (..)) +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Color +import Discord.Internal.Types.Components +import Discord.Internal.Types.Embed +import Discord.Internal.Types.Emoji +import Discord.Internal.Types.Events +import Discord.Internal.Types.Gateway +import Discord.Internal.Types.Guild +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User +import Discord.Internal.Types.RolePermissions + +-- | 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 + InternalResumed a -> Resumed a + InternalChannelCreate a -> ChannelCreate a + InternalChannelUpdate a -> ChannelUpdate a + InternalChannelDelete a -> ChannelDelete a + InternalThreadCreate a -> ThreadCreate a + InternalThreadUpdate a -> ThreadUpdate a + InternalThreadDelete a -> ThreadDelete a + InternalThreadListSync a -> ThreadListSync a + InternalThreadMembersUpdate a -> ThreadMembersUpdate a + InternalChannelPinsUpdate a b -> ChannelPinsUpdate a b + InternalGuildCreate a b -> GuildCreate a b + InternalGuildUpdate a -> GuildUpdate a + InternalGuildDelete a -> GuildDelete a + InternalGuildBanAdd a b -> GuildBanAdd a b + InternalGuildBanRemove a b -> GuildBanRemove a b + InternalGuildEmojiUpdate a b -> GuildEmojiUpdate a b + InternalGuildIntegrationsUpdate a -> GuildIntegrationsUpdate a + InternalGuildMemberAdd a b -> GuildMemberAdd a b + InternalGuildMemberRemove a b -> GuildMemberRemove a b + InternalGuildMemberUpdate a b c d -> GuildMemberUpdate a b c d + InternalGuildMemberChunk a b -> GuildMemberChunk a b + InternalGuildRoleCreate a b -> GuildRoleCreate a b + InternalGuildRoleUpdate a b -> GuildRoleUpdate a b + InternalGuildRoleDelete a b -> GuildRoleDelete a b + InternalMessageCreate a -> MessageCreate a + InternalMessageUpdate a b -> MessageUpdate a b + InternalMessageDelete a b -> MessageDelete a b + InternalMessageDeleteBulk a b -> MessageDeleteBulk a b + InternalMessageReactionAdd a -> MessageReactionAdd a + InternalMessageReactionRemove a -> MessageReactionRemove a + InternalMessageReactionRemoveAll a b -> MessageReactionRemoveAll a b + InternalMessageReactionRemoveEmoji a -> MessageReactionRemoveEmoji a + InternalPresenceUpdate a -> PresenceUpdate a + InternalTypingStart a -> TypingStart a + InternalUserUpdate a -> UserUpdate a + InternalInteractionCreate a -> InteractionCreate a + InternalUnknownEvent a b -> UnknownEvent a b diff --git a/deps/discord-haskell/src/Discord/Internal/Types/ApplicationCommands.hs b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationCommands.hs new file mode 100644 index 0000000..d05a082 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationCommands.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.ApplicationCommands + ( ApplicationCommand (..), + Options (..), + OptionSubcommandOrGroup (..), + OptionSubcommand (..), + OptionValue (..), + createChatInput, + createUser, + createMessage, + CreateApplicationCommand (..), + EditApplicationCommand (..), + defaultEditApplicationCommand, + Choice (..), + ChannelTypeOption (..), + GuildApplicationCommandPermissions (..), + ApplicationCommandPermissions (..), + Number, + AutocompleteOrChoice, + LocalizedText, + Locale + ) +where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Number, Object), object, withArray, withObject, (.!=), (.:), (.:!), (.:?)) +import Data.Aeson.Types (Pair, Parser) +import Data.Foldable (Foldable (toList)) +import Data.Scientific (Scientific) +import Data.Char (isLower, isNumber) +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, Snowflake, objectFromMaybes, (.==), (.=?)) +import Data.Map.Strict (Map) +import Discord.Internal.Types.Channel ( ChannelTypeOption(..) ) + +import qualified Data.Text as T + +type Number = Scientific + +-- | The structure for an application command. +data ApplicationCommand + = ApplicationCommandUser + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. + applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. + applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. + applicationCommandName :: T.Text, + -- | The localized names of the application command. + applicationCommandLocalizedName :: Maybe LocalizedText, + -- | What permissions are required to use this command by default. + applicationCommandDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + applicationCommandDMPermission :: Maybe Bool, + -- | Autoincrementing version identifier updated during substantial record changes. + applicationCommandVersion :: Snowflake + } + | ApplicationCommandMessage + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. + applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. + applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. + applicationCommandName :: T.Text, + -- | The localized names of the application command. + applicationCommandLocalizedName :: Maybe LocalizedText, + -- | What permissions are required to use this command by default. + applicationCommandDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + applicationCommandDMPermission :: Maybe Bool, + -- | Autoincrementing version identifier updated during substantial record changes. + applicationCommandVersion :: Snowflake + } + | ApplicationCommandChatInput + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. + applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. + applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. + applicationCommandName :: T.Text, + -- | The localized names of the application command. + applicationCommandLocalizedName :: Maybe LocalizedText, + -- | The description of the application command. + applicationCommandDescription :: T.Text, + -- | The localized descriptions of the application command. + applicationCommandLocalizedDescription :: Maybe LocalizedText, + -- | The parameters for the command. + applicationCommandOptions :: Maybe Options, + -- | What permissions are required to use this command by default. + applicationCommandDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + applicationCommandDMPermission :: Maybe Bool, + -- | Autoincrementing version identifier updated during substantial record changes. + applicationCommandVersion :: Snowflake + } + deriving (Show, Eq, Read) + +instance FromJSON ApplicationCommand where + parseJSON = + withObject + "ApplicationCommand" + ( \v -> do + acid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + name <- v .: "name" + lname <- v .:? "name_localizations" + defPerm <- v .:? "default_member_permissions" + dmPerm <- v .:? "dm_permission" + version <- v .: "version" + t <- v .:? "type" :: Parser (Maybe Int) + case t of + (Just 2) -> return $ ApplicationCommandUser acid aid gid name lname defPerm dmPerm version + (Just 3) -> return $ ApplicationCommandMessage acid aid gid name lname defPerm dmPerm version + _ -> do + desc <- v .: "description" + options <- v .:? "options" + ldesc <- v .:? "description_localizations" + return $ ApplicationCommandChatInput acid aid gid name lname desc ldesc options defPerm dmPerm version + ) + +-- | Either subcommands and groups, or values. +data Options + = OptionsSubcommands [OptionSubcommandOrGroup] + | OptionsValues [OptionValue] + deriving (Show, Eq, Read) + +instance FromJSON Options where + parseJSON = + withArray + "Options" + ( \a -> do + let a' = toList a + case a' of + [] -> return $ OptionsValues [] + (v' : _) -> + withObject + "Options item" + ( \v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then OptionsSubcommands <$> mapM parseJSON a' + else OptionsValues <$> mapM parseJSON a' + ) + v' + ) + +instance ToJSON Options where + toJSON (OptionsSubcommands o) = toJSON o + toJSON (OptionsValues o) = toJSON o + +-- | Either a subcommand group or a subcommand. +data OptionSubcommandOrGroup + = OptionSubcommandGroup + { -- | The name of the subcommand group + optionSubcommandGroupName :: T.Text, + -- | The localized name of the subcommand group + optionSubcommandGroupLocalizedName :: Maybe LocalizedText, + -- | The description of the subcommand group + optionSubcommandGroupDescription :: T.Text, + -- | The localized description of the subcommand group + optionSubcommandGroupLocalizedDescription :: Maybe LocalizedText, + -- | The subcommands in this subcommand group + optionSubcommandGroupOptions :: [OptionSubcommand] + } + | OptionSubcommandOrGroupSubcommand OptionSubcommand + deriving (Show, Eq, Read) + +instance FromJSON OptionSubcommandOrGroup where + parseJSON = + withObject + "OptionSubcommandOrGroup" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + OptionSubcommandGroup + <$> v .: "name" + <*> v .:? "name_localizations" + <*> v .: "description" + <*> v .:? "description_localizations" + <*> v .: "options" + 1 -> OptionSubcommandOrGroupSubcommand <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) + +instance ToJSON OptionSubcommandOrGroup where + toJSON OptionSubcommandGroup {..} = + object + [ ("type", Number 2), + ("name", toJSON optionSubcommandGroupName), + ("name_localizations", toJSON optionSubcommandGroupLocalizedName), + ("description", toJSON optionSubcommandGroupDescription), + ("description_localizations", toJSON optionSubcommandGroupLocalizedDescription), + ("options", toJSON optionSubcommandGroupOptions) + ] + toJSON (OptionSubcommandOrGroupSubcommand a) = toJSON a + +-- | Data for a single subcommand. +data OptionSubcommand = OptionSubcommand + { -- | The name of the subcommand + optionSubcommandName :: T.Text, + -- | The localized name of the subcommand + optionSubcommandLocalizedName :: Maybe LocalizedText, + -- | The description of the subcommand + optionSubcommandDescription :: T.Text, + -- | The localized description of the subcommand + optionSubcommandLocalizedDescription :: Maybe LocalizedText, + -- | What options are there in this subcommand + optionSubcommandOptions :: [OptionValue] + } + deriving (Show, Eq, Read) + +instance FromJSON OptionSubcommand where + parseJSON = + withObject + "OptionSubcommand" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + OptionSubcommand + <$> v .: "name" + <*> v .:? "name_localizations" + <*> v .: "description" + <*> v .:? "description_localizations" + <*> v .:? "options" .!= [] + _ -> fail "unexpected subcommand type" + ) + +instance ToJSON OptionSubcommand where + toJSON OptionSubcommand {..} = + object + [ ("type", Number 1), + ("name", toJSON optionSubcommandName), + ("name_localizations", toJSON optionSubcommandLocalizedName), + ("description", toJSON optionSubcommandDescription), + ("description_localizations", toJSON optionSubcommandLocalizedDescription), + ("options", toJSON optionSubcommandOptions) + ] + +-- | Data for a single value. +data OptionValue + = OptionValueString + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + optionValueStringChoices :: AutocompleteOrChoice T.Text, + -- | The minimum length of the string (minimum 0) + optionValueStringMinLen :: Maybe Integer, + -- | The maximum length of the string (minimum 1) + optionValueStringMaxLen :: Maybe Integer + } + | OptionValueInteger + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + optionValueIntegerChoices :: AutocompleteOrChoice Integer, + -- | The lower bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueIntegerMinVal :: Maybe Integer, + -- | The upper bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueIntegerMaxVal :: Maybe Integer + } + | OptionValueBoolean + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueUser + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueChannel + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | What type of channel can be put in here + optionValueChannelTypes :: Maybe [ChannelTypeOption] + } + | OptionValueRole + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueMentionable + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueNumber + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + optionValueNumberChoices :: AutocompleteOrChoice Number, + -- | The lower bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueNumberMinVal :: Maybe Number, + -- | The upper bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueNumberMaxVal :: Maybe Number + } + deriving (Show, Eq, Read) + +instance FromJSON OptionValue where + parseJSON = + withObject + "OptionValue" + ( \v -> do + name <- v .: "name" + lname <- v .:? "name_localizations" + desc <- v .: "description" + ldesc <- v .:? "description_localizations" + required <- v .:? "required" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + OptionValueString name lname desc ldesc required + <$> parseJSON (Object v) + <*> v .:? "min_length" + <*> v .:? "max_length" + 4 -> + OptionValueInteger name lname desc ldesc required + <$> parseJSON (Object v) + <*> v .:? "min_value" + <*> v .:? "max_value" + 10 -> + OptionValueNumber name lname desc ldesc required + <$> parseJSON (Object v) + <*> v .:? "min_value" + <*> v .:? "max_value" + 7 -> + OptionValueChannel name lname desc ldesc required + <$> v .:? "channel_types" + 5 -> return $ OptionValueBoolean name lname desc ldesc required + 6 -> return $ OptionValueUser name lname desc ldesc required + 8 -> return $ OptionValueRole name lname desc ldesc required + 9 -> return $ OptionValueMentionable name lname desc ldesc required + _ -> fail "unknown application command option value type" + ) + +instance ToJSON OptionValue where + toJSON OptionValueString {..} = + object + [ ("type", Number 3), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("min_length", toJSON optionValueStringMinLen), + ("max_length", toJSON optionValueStringMaxLen), + choiceOrAutocompleteToJSON optionValueStringChoices + ] + toJSON OptionValueInteger {..} = + object + [ ("type", Number 4), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("min_value", toJSON optionValueIntegerMinVal), + ("max_value", toJSON optionValueIntegerMaxVal), + choiceOrAutocompleteToJSON optionValueIntegerChoices + ] + toJSON OptionValueNumber {..} = + object + [ ("type", Number 10), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("min_value", toJSON optionValueNumberMinVal), + ("max_value", toJSON optionValueNumberMaxVal), + choiceOrAutocompleteToJSON optionValueNumberChoices + ] + toJSON OptionValueChannel {..} = + object + [ ("type", Number 7), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("channel_types", toJSON optionValueChannelTypes) + ] + toJSON acov = + object + [ ("type", Number (t acov)), + ("name", toJSON $ optionValueName acov), + ("description", toJSON $ optionValueDescription acov), + ("name_localizations", toJSON $ optionValueLocalizedName acov), + ("description_localizations", toJSON $ optionValueLocalizedDescription acov), + ("required", toJSON $ optionValueRequired acov) + ] + where + t OptionValueBoolean {} = 5 + t OptionValueUser {} = 6 + t OptionValueRole {} = 8 + t OptionValueMentionable {} = 9 + t _ = -1 + +-- | Data type to be used when creating application commands. The specification +-- is below. +-- +-- If a command of the same type and and name is sent to the server, it will +-- overwrite any command that already exists in the same scope (guild vs +-- global). +-- +-- The description has to be empty for non-slash command application +-- commands, as do the options. The options need to be `Nothing` for non-slash +-- commands, too. If one of the options is a subcommand or subcommand group, +-- the base command will no longer be usable. +-- +-- A subcommand group can have subcommands within it. This is the maximum amount +-- of command nesting permitted. +-- +-- https://discord.com/developers/docs/interactions/application-commands#create-global-application-command +data CreateApplicationCommand + = CreateApplicationCommandChatInput + { -- | The application command name (1-32 chars). + createName :: T.Text, + -- | The localized application name + createLocalizedName :: Maybe LocalizedText, + -- | The application command description (1-100 chars). + createDescription :: T.Text, + -- | The localized application command description. + createLocalizedDescription :: Maybe LocalizedText, + -- | 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 available in DMs. + createDMPermission :: Maybe Bool + } + | CreateApplicationCommandUser + { -- | The application command name (1-32 chars). + createName :: T.Text, + -- | The localized application name + createLocalizedName :: Maybe LocalizedText, + -- | 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 available in DMs. + createDMPermission :: Maybe Bool + } + | CreateApplicationCommandMessage + { -- | The application command name (1-32 chars). + createName :: T.Text, + -- | The localized application name + createLocalizedName :: Maybe LocalizedText, + -- | 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 available in DMs. + createDMPermission :: Maybe Bool + } + deriving (Show, Eq, Read) + +instance ToJSON CreateApplicationCommand where + toJSON CreateApplicationCommandChatInput {..} = + objectFromMaybes + [ "name" .== createName, + "name_localizations" .=? createLocalizedName, + "description" .== createDescription, + "description_localizations" .=? createLocalizedDescription, + "options" .=? createOptions, + "default_member_permissions" .== createDefaultMemberPermissions, + "dm_permission" .== createDMPermission, + "type" .== Number 1 + ] + toJSON CreateApplicationCommandUser {..} = + objectFromMaybes + [ "name" .== createName, + "name_localizations" .=? createLocalizedName, + "default_member_permissions" .== createDefaultMemberPermissions, + "dm_permission" .== createDMPermission, + "type" .== Number 2 + ] + toJSON CreateApplicationCommandMessage {..} = + objectFromMaybes + [ "name" .== createName, + "name_localizations" .=? createLocalizedName, + "default_member_permissions" .== createDefaultMemberPermissions, + "dm_permission" .== createDMPermission, + "type" .== Number 3 + ] + +nameIsValid :: Bool -> T.Text -> Bool +nameIsValid isChatInput name = l >= 1 && l <= 32 && isChatInput <= T.all validChar name + where + l = T.length name + validChar c = c == '-' || c == '_' || isLower c || isNumber c + +-- | Create the basics for a chat input (slash command). Use record overwriting +-- to enter the other values. The name needs to be all lower case letters, and +-- between 1 and 32 characters. The description has to be non-empty and less +-- 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 Nothing desc Nothing Nothing Nothing Nothing + | 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 Nothing Nothing Nothing + | 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 Nothing Nothing Nothing + | otherwise = Nothing + +-- | Data type to be used when editing application commands. The specification +-- is below. See `CreateApplicationCommand` for an explanation for the +-- parameters. +-- +-- https://discord.com/developers/docs/interactions/application-commands#edit-global-application-command +data EditApplicationCommand + = EditApplicationCommandChatInput + { editName :: Maybe T.Text, + editLocalizedName :: Maybe LocalizedText, + editDescription :: Maybe T.Text, + editLocalizedDescription :: Maybe LocalizedText, + editOptions :: Maybe Options, + editDefaultMemberPermissions :: Maybe T.Text, + editDMPermission :: Maybe Bool + } + | EditApplicationCommandUser + { editName :: Maybe T.Text, + editLocalizedName :: Maybe LocalizedText, + editDefaultMemberPermissions :: Maybe T.Text, + editDMPermission :: Maybe Bool + } + | EditApplicationCommandMessage + { editName :: Maybe T.Text, + editLocalizedName :: Maybe LocalizedText, + editDefaultMemberPermissions :: Maybe T.Text, + editDMPermission :: Maybe Bool + } + +defaultEditApplicationCommand :: Int -> EditApplicationCommand +defaultEditApplicationCommand 2 = EditApplicationCommandUser Nothing Nothing Nothing Nothing +defaultEditApplicationCommand 3 = EditApplicationCommandMessage Nothing Nothing Nothing Nothing +defaultEditApplicationCommand _ = EditApplicationCommandChatInput Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON EditApplicationCommand where + toJSON EditApplicationCommandChatInput {..} = + objectFromMaybes + [ "name" .=? editName, + "name_localization" .=? editLocalizedName, + "description" .=? editDescription, + "description_localization" .=? editLocalizedDescription, + "options" .=? editOptions, + "default_member_permissions" .=? editDefaultMemberPermissions, + "dm_permission" .=? editDMPermission, + "type" .== Number 1 + ] + toJSON EditApplicationCommandUser {..} = + objectFromMaybes + [ "name" .=? editName, + "name_localization" .=? editLocalizedName, + "default_member_permissions" .=? editDefaultMemberPermissions, + "dm_permission" .=? editDMPermission, + "type" .== Number 2 + ] + toJSON EditApplicationCommandMessage {..} = + objectFromMaybes + [ "name" .=? editName, + "name_localization" .=? editLocalizedName, + "default_member_permissions" .=? editDefaultMemberPermissions, + "dm_permission" .=? editDMPermission, + "type" .== Number 3 + ] + +data Choice a = Choice + { -- | The name of the choice + choiceName :: T.Text, + -- | The localized name of the choice + choiceLocalizedName :: Maybe LocalizedText, + -- | The value of the choice + choiceValue :: a + } + deriving (Show, Read, Eq, Ord) + +instance Functor Choice where + fmap f (Choice s l a) = Choice s l (f a) + +instance (ToJSON a) => ToJSON (Choice a) where + toJSON Choice {..} = + object + [ ("name", toJSON choiceName), + ("value", toJSON choiceValue), + ("name_localizations", toJSON choiceLocalizedName) + ] + +instance (FromJSON a) => FromJSON (Choice a) where + parseJSON = + withObject + "Choice" + ( \v -> + Choice + <$> v .: "name" + <*> v .:? "name_localizations" + <*> v .: "value" + ) + +type AutocompleteOrChoice a = Either Bool [Choice a] + +instance {-# OVERLAPPING #-} (FromJSON a) => FromJSON (AutocompleteOrChoice a) where + parseJSON = + withObject + "AutocompleteOrChoice" + ( \v -> do + mcs <- v .:! "choices" + case mcs of + Nothing -> Left <$> v .:? "autocomplete" .!= False + Just cs -> return $ Right cs + ) + +choiceOrAutocompleteToJSON :: (ToJSON a) => AutocompleteOrChoice a -> Pair +choiceOrAutocompleteToJSON (Left b) = ("autocomplete", toJSON b) +choiceOrAutocompleteToJSON (Right cs) = ("choices", toJSON cs) + +data GuildApplicationCommandPermissions = GuildApplicationCommandPermissions + { -- | The id of the command. + guildApplicationCommandPermissionsId :: ApplicationCommandId, + -- | The id of the application. + guildApplicationCommandPermissionsApplicationId :: ApplicationId, + -- | The id of the guild. + guildApplicationCommandPermissionsGuildId :: GuildId, + -- | The permissions for the command in the guild. + guildApplicationCommandPermissionsPermissions :: [ApplicationCommandPermissions] + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildApplicationCommandPermissions where + parseJSON = + withObject + "GuildApplicationCommandPermissions" + ( \v -> + GuildApplicationCommandPermissions + <$> v .: "id" + <*> v .: "application_id" + <*> v .: "guild_id" + <*> v .: "permissions" + ) + +instance ToJSON GuildApplicationCommandPermissions where + toJSON GuildApplicationCommandPermissions {..} = + objectFromMaybes + [ "id" .== guildApplicationCommandPermissionsId, + "application_id" .== guildApplicationCommandPermissionsApplicationId, + "guild_id" .== guildApplicationCommandPermissionsGuildId, + "permissions" .== guildApplicationCommandPermissionsPermissions + ] + +-- | Application command permissions allow you to enable or disable commands for +-- specific users or roles within a guild. +data ApplicationCommandPermissions = ApplicationCommandPermissions + { -- | The id of the role or user. + applicationCommandPermissionsId :: Snowflake, + -- | Choose either role (1) or user (2). + applicationCommandPermissionsType :: Integer, + -- | Whether to allow or not. + applicationCommandPermissionsPermission :: Bool + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ApplicationCommandPermissions where + parseJSON = + withObject + "ApplicationCommandPermissions" + ( \v -> + ApplicationCommandPermissions + <$> v .: "id" + <*> v .: "type" + <*> v .: "permission" + ) + +instance ToJSON ApplicationCommandPermissions where + toJSON ApplicationCommandPermissions {..} = + objectFromMaybes + [ "id" .== applicationCommandPermissionsId, + "type" .== applicationCommandPermissionsType, + "permission" .== applicationCommandPermissionsPermission + ] + +-- | A discord locale. See +-- <https://discord.com/developers/docs/reference#locales> for available locales +type Locale = T.Text + +-- | Translations for a text +type LocalizedText = Map Locale T.Text diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs new file mode 100644 index 0000000..9f4671a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs @@ -0,0 +1,879 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Data structures pertaining to Discord Channels +module Discord.Internal.Types.Channel ( + Channel (..) + , channelIsInGuild + , Overwrite (..) + , ThreadMetadata (..) + , ThreadMember (..) + , ThreadListSyncFields (..) + , ThreadMembersUpdateFields (..) + , Message (..) + , AllowedMentions (..) + , MessageReaction (..) + , Attachment (..) + , Nonce (..) + , MessageReference (..) + , MessageType (..) + , MessageActivity (..) + , MessageActivityType (..) + , MessageFlag (..) + , MessageFlags (..) + , MessageInteraction (..) + + , ChannelTypeOption (..) + ) where + +import Control.Applicative (empty) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Default (Default, def) +import Data.Text (Text) +import Data.Time.Clock +import qualified Data.Text as T +import Data.Bits +import Data.Data (Data) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User (User(..), GuildMember) +import Discord.Internal.Types.Embed +import Discord.Internal.Types.Components (ActionRow) +import Discord.Internal.Types.Emoji + +-- | Guild channels represent an isolated set of users and messages in a Guild (Server) +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). + , 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 -- ^ 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 -- ^ 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 -- ^ 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 -- ^ 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 -- ^ 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 -- ^ 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 -- ^ 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). + , 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 + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this 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). + , 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 + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this 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). + , 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 + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } + -- | A channel of unknown type + | ChannelUnknownType + { 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 + parseJSON = withObject "Channel" $ \o -> do + type' <- (o .: "type") :: Parser Int + case type' of + 0 -> + ChannelText <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .: "rate_limit_per_user" + <*> o .:? "nsfw" .!= False + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + 1 -> + ChannelDirectMessage <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 2 -> + ChannelVoice <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "nsfw" .!= False + <*> o .: "bitrate" + <*> o .: "user_limit" + <*> o .:? "parent_id" + 3 -> + ChannelGroupDM <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 4 -> + ChannelGuildCategory <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + 5 -> + ChannelNews <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "nsfw" .!= False + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + 6 -> + ChannelStorePage <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .:? "nsfw" .!= False + <*> o .: "permission_overwrites" + <*> o .:? "parent_id" + 10 -> ChannelNewsThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 11 -> ChannelPublicThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 12 -> ChannelPrivateThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 13 -> + ChannelStage <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "id" + <*> o .:? "topic" .!= "" + _ -> ChannelUnknownType <$> o .: "id" + <*> pure (T.pack (show o)) + +instance ToJSON Channel where + toJSON ChannelText{..} = objectFromMaybes + [ "type" .== Number 0 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "position" .== channelPosition + , "rate_limit_per_user" .== channelUserRateLimit + , "nsfw" .== channelNSFW + , "permission_overwrites" .== channelPermissions + , "topic" .== channelTopic + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + ] + toJSON ChannelNews{..} = objectFromMaybes + [ "type" .== Number 5 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "position" .== channelPosition + , "permission_overwrites" .== channelPermissions + , "nsfw" .== channelNSFW + , "topic" .== channelTopic + , "last_message_id" .=? channelLastMessage + , "parent_id" .=? channelParentId + ] + toJSON ChannelStorePage{..} = objectFromMaybes + [ "type" .== Number 6 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "nsfw" .== channelNSFW + , "position" .== channelPosition + , "permission_overwrites" .== channelPermissions + ] + toJSON ChannelDirectMessage{..} = objectFromMaybes + [ "type" .== Number 1 + , "id" .== channelId + , "recipients" .== channelRecipients + , "last_message_id" .=? channelLastMessage + ] + toJSON ChannelVoice{..} = objectFromMaybes + [ "type" .== Number 2 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "position" .== channelPosition + , "nsfw" .== channelNSFW + , "permission_overwrites" .== channelPermissions + , "bitrate" .== channelBitRate + , "user_limit" .== channelUserLimit + ] + toJSON ChannelGroupDM{..} = objectFromMaybes + [ "type" .== Number 3 + , "id" .== channelId + , "recipients" .== channelRecipients + , "last_message_id" .=? channelLastMessage + ] + toJSON ChannelGuildCategory{..} = objectFromMaybes + [ "type" .== Number 4 + , "id" .== channelId + , "name" .== channelName + , "guild_id" .== channelGuild + ] + toJSON ChannelStage{..} = objectFromMaybes + [ "type" .== Number 13 + , "id" .== channelId + , "guild_id" .== channelGuild + , "channel_id" .== channelStageId + , "topic" .== channelStageTopic + ] + toJSON ChannelNewsThread{..} = objectFromMaybes + [ "type" .== Number 10 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .=? channelThreadName + , "rate_limit_per_user" .=? channelUserRateLimitThread + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + , "thread_metadata" .=? channelThreadMetadata + , "member" .=? channelThreadMember + ] + toJSON ChannelPublicThread{..} = objectFromMaybes + [ "type" .== Number 11 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .=? channelThreadName + , "rate_limit_per_user" .=? channelUserRateLimitThread + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + , "thread_metadata" .=? channelThreadMetadata + , "member" .=? channelThreadMember + ] + toJSON ChannelPrivateThread{..} = objectFromMaybes + [ "type" .== Number 12 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .=? channelThreadName + , "rate_limit_per_user" .=? channelUserRateLimitThread + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + , "thread_metadata" .=? channelThreadMetadata + , "member" .=? channelThreadMember + ] + toJSON ChannelUnknownType{..} = objectFromMaybes + [ "id" .== channelId + , "json" .== channelJSON + ] + +-- | If the channel is part of a guild (has a guild id field) +channelIsInGuild :: Channel -> Bool +channelIsInGuild c = case c of + ChannelGuildCategory{} -> True + ChannelText{} -> True + ChannelVoice{} -> True + ChannelNews{} -> True + ChannelStorePage{} -> True + ChannelNewsThread{} -> True + ChannelPublicThread{} -> True + ChannelPrivateThread{} -> True + _ -> False + +-- | Permission overwrites for a channel. +data Overwrite = Overwrite + { 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 -> 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 $ either unId unId overwriteId) + , ("type", toJSON (either (const 0) (const 1) overwriteId :: Int)) + , ("allow", toJSON overwriteAllow) + , ("deny", toJSON overwriteDeny) + ] + +-- | Metadata for threads. +data ThreadMetadata = ThreadMetadata + { threadMetadataArchived :: Bool -- ^ Is the thread archived? + , threadMetadataAutoArchive :: Integer -- ^ How long after activity should the thread auto archive + , threadMetadataArchiveTime :: UTCTime -- ^ When was the last time the archive status changed? + , threadMetadataLocked :: Bool -- ^ Is the thread locked? (only MANAGE_THREADS users can unarchive) + , threadMetadataInvitable :: Maybe Bool -- ^ Can non-mods add other non-mods? (private threads only) + , threadMetadataCreateTime :: Maybe UTCTime -- ^ When was the thread created? + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMetadata where + parseJSON = withObject "ThreadMetadata" $ \o -> + ThreadMetadata <$> o .: "archived" + <*> o .: "auto_archive_duration" + <*> o .: "archive_timestamp" + <*> o .: "locked" + <*> o .:? "invitable" + <*> o .:? "create_timestamp" + +instance ToJSON ThreadMetadata where + toJSON ThreadMetadata{..} = objectFromMaybes + [ "archived" .== threadMetadataArchived + , "auto_archive_duration" .== threadMetadataAutoArchive + , "archive_timestamp" .== threadMetadataArchiveTime + , "locked" .== threadMetadataLocked + , "invitable" .=? threadMetadataInvitable + , "create_timestamp" .== threadMetadataCreateTime + ] + +-- | A user in a thread +data ThreadMember = ThreadMember + { threadMemberThreadId :: Maybe ChannelId -- ^ id of the thread + , threadMemberUserId :: Maybe UserId -- ^ id of the user + , threadMemberJoinTime :: UTCTime -- ^ time the current user last joined the thread + , threadMemberFlags :: Integer -- ^ user-thread settings + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMember where + parseJSON = withObject "ThreadMember" $ \o -> + ThreadMember <$> o .:? "id" + <*> o .:? "user_id" + <*> o .: "join_timestamp" + <*> o .: "flags" + +instance ToJSON ThreadMember where + toJSON ThreadMember{..} = objectFromMaybes + [ "id" .=? threadMemberThreadId + , "user_id" .=? threadMemberUserId + , "join_timestamp" .== threadMemberJoinTime + , "flags" .== threadMemberFlags + ] + + +data ThreadListSyncFields = ThreadListSyncFields + { threadListSyncFieldsGuildId :: GuildId + , threadListSyncFieldsChannelIds :: Maybe [ChannelId] + , threadListSyncFieldsThreads :: [Channel] + , threadListSyncFieldsThreadMembers :: [ThreadMember] + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadListSyncFields where + parseJSON = withObject "ThreadListSyncFields" $ \o -> + ThreadListSyncFields <$> o .: "guild_id" + <*> o .:? "channel_ids" + <*> o .: "threads" + <*> o .: "members" + +data ThreadMembersUpdateFields = ThreadMembersUpdateFields + { threadMembersUpdateFieldsThreadId :: ChannelId + , threadMembersUpdateFieldsGuildId :: GuildId + , threadMembersUpdateFieldsMemberCount :: Integer + , threadMembersUpdateFieldsAddedMembers :: Maybe [ThreadMember] + , threadMembersUpdateFieldsRemovedMembers :: Maybe [UserId] + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMembersUpdateFields where + parseJSON = withObject "ThreadMembersUpdateFields" $ \o -> + ThreadMembersUpdateFields <$> o .: "id" + <*> o .: "guild_id" + <*> o .: "member_count" + <*> o .:? "added_members" + <*> o .:? "removed_member_ids" + +-- | Represents information about a message in a Discord channel. +data Message = Message + { messageId :: MessageId -- ^ The id of the message + , messageChannelId :: ChannelId -- ^ Id of the channel the message + -- was sent in + , messageGuildId :: Maybe GuildId -- ^ The guild the message went to + , messageAuthor :: User -- ^ The 'User' the message was sent + -- by + , messageMember :: Maybe GuildMember -- ^ A partial guild member object + , messageContent :: Text -- ^ Contents of the message + , messageTimestamp :: UTCTime -- ^ When the message was sent + , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited + , messageTts :: Bool -- ^ Whether this message was a TTS + -- message + , messageEveryone :: Bool -- ^ Whether this message mentions + -- everyone + , messageMentions :: [User] -- ^ 'User's specifically mentioned in + -- the message + , messageMentionRoles :: [RoleId] -- ^ 'Role's specifically mentioned in + -- the message + , messageAttachments :: [Attachment] -- ^ Any attached files + , messageEmbeds :: [Embed] -- ^ Any embedded content + , messageReactions :: [MessageReaction] -- ^ Any reactions to message + , messageNonce :: Maybe Nonce -- ^ Used for validating if a message + -- was sent + , messagePinned :: Bool -- ^ Whether this message is pinned + , messageWebhookId :: Maybe WebhookId -- ^ The webhook id of the webhook that made the message + , messageType :: MessageType -- ^ What type of message is this. + , messageActivity :: Maybe MessageActivity -- ^ sent with Rich Presence-related chat embeds + , messageApplicationId :: Maybe ApplicationId -- ^ if the message is a response to an Interaction, this is the id of the interaction's application + , messageReference :: Maybe MessageReference -- ^ Reference IDs of the original message + , messageFlags :: Maybe MessageFlags -- ^ Various message flags + , messageReferencedMessage :: Maybe Message -- ^ The full original message + , messageInteraction :: Maybe MessageInteraction -- ^ sent if message is an interaction response + , messageThread :: Maybe Channel -- ^ the thread that was started from this message, includes thread member object + , messageComponents :: Maybe [ActionRow] -- ^ sent if the message contains components like buttons, action rows, or other interactive components + , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Message where + parseJSON = withObject "Message" $ \o -> + Message <$> o .: "id" + <*> o .: "channel_id" + <*> o .:? "guild_id" .!= Nothing + <*> (do isW <- o .:? "webhook_id" + a <- o .: "author" + case isW :: Maybe WebhookId of + Nothing -> pure a + Just _ -> pure $ a { userIsWebhook = True }) + <*> o .:? "member" + <*> o .:? "content" .!= "" + <*> o .:? "timestamp" .!= epochTime + <*> o .:? "edited_timestamp" + <*> o .:? "tts" .!= False + <*> o .:? "mention_everyone" .!= False + <*> o .:? "mentions" .!= [] + <*> o .:? "mention_roles" .!= [] + <*> o .:? "attachments" .!= [] + <*> o .: "embeds" + <*> o .:? "reactions" .!= [] + <*> o .:? "nonce" + <*> o .:? "pinned" .!= False + <*> o .:? "webhook_id" + <*> o .: "type" + <*> o .:? "activity" + -- <*> o .:? "application" + <*> o .:? "application_id" + <*> o .:? "message_reference" .!= Nothing + <*> o .:? "flags" + <*> o .:? "referenced_message" .!= Nothing + <*> o .:? "interaction" + <*> o .:? "thread" + <*> o .:? "components" + <*> o .:? "sticker_items" + + +instance ToJSON Message where + toJSON Message {..} = objectFromMaybes + [ "id" .== messageId + , "channel_id" .== messageChannelId + , "guild_id" .=? messageGuildId + , "author" .== messageAuthor + , "member" .=? messageMember + , "content" .== messageContent + , "timestamp" .== messageTimestamp + , "edited_timestamp" .=? messageEdited + , "tts" .== messageTts + , "mention_everyone" .== messageEveryone + , "mentions" .== messageMentions + , "mention_roles" .== messageMentionRoles + , "attachments" .== messageAttachments + , "embeds" .== messageEmbeds + , "reactions" .== messageReactions + , "nonce" .=? messageNonce + , "pinned" .== messagePinned + , "webhook_id" .=? messageWebhookId + , "type" .== messageType + , "activity" .=? messageActivity + -- , ("application", toJSON <$> messageApplication) + , "application_id" .=? messageApplicationId + , "message_reference" .=? messageReference + , "flags" .=? messageFlags + , "referenced_message" .=? messageReferencedMessage + , "interaction" .=? messageInteraction + , "thread" .=? messageThread + , "components" .=? messageComponents + , "sticker_items" .=? messageStickerItems + ] + +-- | Data constructor for a part of MessageDetailedOpts. +data AllowedMentions = AllowedMentions + { 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 + def = AllowedMentions { mentionEveryone = False + , mentionUsers = True + , mentionRoles = True + , mentionUserIds = [] + , mentionRoleIds = [] + , mentionRepliedUser = True + } + +instance ToJSON AllowedMentions where + toJSON AllowedMentions{..} = object [ + "parse" .= [name :: T.Text | (name, True) <- + [ ("everyone", mentionEveryone), + ("users", mentionUsers && null mentionUserIds), + ("roles", mentionRoles && null mentionRoleIds) ] ], + -- https://discord.com/developers/docs/resources/channel#allowed-mentions-object + -- parse.users and users list cannot both be active, prioritize id list + "roles" .= mentionRoleIds, + "users" .= mentionUserIds, + "replied_user" .= mentionRepliedUser ] + +-- | A reaction to a message +data MessageReaction = MessageReaction + { messageReactionCount :: Int + , messageReactionMeIncluded :: Bool + , messageReactionEmoji :: Emoji + } deriving (Show, Read, Eq, Ord) + +instance FromJSON MessageReaction where + parseJSON = withObject "MessageReaction" $ \o -> + MessageReaction <$> o .: "count" + <*> o .: "me" + <*> o .: "emoji" + +instance ToJSON MessageReaction where + toJSON MessageReaction{..} = objectFromMaybes + [ "count" .== messageReactionCount + , "me" .== messageReactionMeIncluded + , "emoji" .== messageReactionEmoji + ] + +-- | Represents an attached to a message file. +data Attachment = Attachment + { attachmentId :: AttachmentId -- ^ Attachment id + , attachmentFilename :: T.Text -- ^ Name of attached file + , attachmentSize :: Integer -- ^ Size of file (in bytes) + , attachmentUrl :: T.Text -- ^ Source of file + , attachmentProxy :: T.Text -- ^ Proxied url of file + , attachmentHeight :: Maybe Integer -- ^ Height of file (if image) + , attachmentWidth :: Maybe Integer -- ^ Width of file (if image) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Attachment where + parseJSON = withObject "Attachment" $ \o -> + Attachment <$> o .: "id" + <*> o .: "filename" + <*> o .: "size" + <*> o .: "url" + <*> o .: "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +instance ToJSON Attachment where + toJSON Attachment {..} = objectFromMaybes + [ "id" .== attachmentId + , "filename" .== attachmentFilename + , "size" .== attachmentSize + , "url" .== attachmentUrl + , "proxy_url" .== attachmentProxy + , "height" .=? attachmentHeight + , "width" .=? attachmentWidth + ] + +newtype Nonce = Nonce T.Text + deriving (Show, Read, Eq, Ord) + +instance FromJSON Nonce where + parseJSON (String nonce) = pure $ Nonce nonce + parseJSON (Number nonce) = pure . Nonce . T.pack . show $ nonce + parseJSON _ = empty + +instance ToJSON Nonce where + toJSON (Nonce t) = String t + + +-- | Represents a Message Reference +data MessageReference = MessageReference + { referenceMessageId :: Maybe MessageId -- ^ id of the originating message + , referenceChannelId :: Maybe ChannelId -- ^ id of the originating message's channel + , referenceGuildId :: Maybe GuildId -- ^ id of the originating message's guild + , failIfNotExists :: Bool -- ^ Whether to not send if reference not exist + } deriving (Show, Read, Eq, Ord) + +instance FromJSON MessageReference where + parseJSON = withObject "MessageReference" $ \o -> + MessageReference <$> o .:? "message_id" + <*> o .:? "channel_id" + <*> o .:? "guild_id" + <*> o .:? "fail_if_not_exists" .!= True + +instance ToJSON MessageReference where + toJSON MessageReference{..} = objectFromMaybes + [ "message_id" .== referenceMessageId + , "channel_id" .== referenceChannelId + , "guild_id" .== referenceGuildId + , "fail_if_not_exists" .== failIfNotExists + ] + +instance Default MessageReference where + def = MessageReference { referenceMessageId = Nothing + , referenceChannelId = Nothing + , referenceGuildId = Nothing + , failIfNotExists = False + } + + +data MessageType + = MessageTypeDefault + | MessageTypeRecipientAdd + | MessageTypeRecipientRemove + | MessageTypeCall + | MessageTypeChannelNameChange + | MessageTypeChannelIconChange + | MessageTypeChannelPinnedMessage + | MessageTypeGuildMemberJoin + | MessageTypeUserPremiumGuildSubscription + | MessageTypeUserPremiumGuildSubscriptionTier1 + | MessageTypeUserPremiumGuildSubscriptionTier2 + | MessageTypeUserPremiumGuildSubscriptionTier3 + | MessageTypeChannelFollowAdd + | MessageTypeGuildDiscoveryDisqualified + | MessageTypeGuildDiscoveryRequalified + | MessageTypeGuildDiscoveryGracePeriodInitialWarning + | MessageTypeGuildDiscoveryGracePeriodFinalWarning + | MessageTypeThreadCreated + | MessageTypeReply + | MessageTypeChatInputCommand + | MessageTypeThreadStarterMessage + | MessageTypeGuildInviteReminder + | MessageTypeContextMenuCommand + deriving (Show, Read, Data, Eq, Ord) + +instance InternalDiscordEnum MessageType where + discordTypeStartValue = MessageTypeDefault + fromDiscordType MessageTypeDefault = 0 + fromDiscordType MessageTypeRecipientAdd = 1 + fromDiscordType MessageTypeRecipientRemove = 2 + fromDiscordType MessageTypeCall = 3 + fromDiscordType MessageTypeChannelNameChange = 4 + fromDiscordType MessageTypeChannelIconChange = 5 + fromDiscordType MessageTypeChannelPinnedMessage = 6 + fromDiscordType MessageTypeGuildMemberJoin = 7 + fromDiscordType MessageTypeUserPremiumGuildSubscription = 8 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier1 = 9 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier2 = 10 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier3 = 11 + fromDiscordType MessageTypeChannelFollowAdd = 12 + fromDiscordType MessageTypeGuildDiscoveryDisqualified = 14 + fromDiscordType MessageTypeGuildDiscoveryRequalified = 15 + fromDiscordType MessageTypeGuildDiscoveryGracePeriodInitialWarning = 16 + fromDiscordType MessageTypeGuildDiscoveryGracePeriodFinalWarning = 17 + fromDiscordType MessageTypeThreadCreated = 18 + fromDiscordType MessageTypeReply = 19 + fromDiscordType MessageTypeChatInputCommand = 20 + fromDiscordType MessageTypeThreadStarterMessage = 21 + fromDiscordType MessageTypeGuildInviteReminder = 22 + fromDiscordType MessageTypeContextMenuCommand = 23 + +instance ToJSON MessageType where + toJSON = toJSON . fromDiscordType + +instance FromJSON MessageType where + parseJSON = discordTypeParseJSON "MessageType" + +data MessageActivity = MessageActivity + { messageActivityType :: MessageActivityType + , messageActivityPartyId :: Maybe T.Text + } + deriving (Show, Read, Data, Eq, Ord) + +instance FromJSON MessageActivity where + parseJSON = withObject "MessageActivity" $ \o -> + MessageActivity <$> o .: "type" + <*> o .:? "party_id" + +instance ToJSON MessageActivity where + toJSON MessageActivity{..} = objectFromMaybes + [ "type" .== messageActivityType + , "party_id" .=? messageActivityPartyId + ] + +data MessageActivityType + = MessageActivityTypeJoin -- ^ Join a Rich Presence event + | MessageActivityTypeSpectate -- ^ Spectate a Rich Presence event + | MessageActivityTypeListen -- ^ Listen to a Rich Presence event + | MessageActivityTypeJoinRequest -- ^ Request to join a Rich Presence event + deriving (Show, Read, Data, Eq, Ord) + +instance InternalDiscordEnum MessageActivityType where + discordTypeStartValue = MessageActivityTypeJoin + fromDiscordType MessageActivityTypeJoin = 1 + fromDiscordType MessageActivityTypeSpectate = 2 + fromDiscordType MessageActivityTypeListen = 3 + fromDiscordType MessageActivityTypeJoinRequest = 4 + +instance ToJSON MessageActivityType where + toJSON = toJSON . fromDiscordType + +instance FromJSON MessageActivityType where + parseJSON = discordTypeParseJSON "MessageActivityType" + +-- | Types of flags to attach to the message. +data MessageFlag = + MessageFlagCrossposted + | MessageFlagIsCrosspost + | MessageFlagSupressEmbeds + | MessageFlagSourceMessageDeleted + | MessageFlagUrgent + | MessageFlagHasThread + | MessageFlagEphemeral + | MessageFlagLoading + | MessageFlagFailedToMentionRollesInThread + deriving (Show, Read, Eq, Data, Ord) + +newtype MessageFlags = MessageFlags [MessageFlag] + deriving (Show, Read, Eq, Ord) + +instance InternalDiscordEnum MessageFlag where + discordTypeStartValue = MessageFlagCrossposted + fromDiscordType MessageFlagCrossposted = 1 `shift` 0 + fromDiscordType MessageFlagIsCrosspost = 1 `shift` 1 + fromDiscordType MessageFlagSupressEmbeds = 1 `shift` 2 + fromDiscordType MessageFlagSourceMessageDeleted = 1 `shift` 3 + fromDiscordType MessageFlagUrgent = 1 `shift` 4 + fromDiscordType MessageFlagHasThread = 1 `shift` 5 + fromDiscordType MessageFlagEphemeral = 1 `shift` 6 + fromDiscordType MessageFlagLoading = 1 `shift` 7 + fromDiscordType MessageFlagFailedToMentionRollesInThread = 1 `shift` 8 + +instance ToJSON MessageFlags where + toJSON (MessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromDiscordType <$> fs) + +-- TODO: maybe make this a type class or something - the ability to handle flags automatically would be Very Good. + +instance FromJSON MessageFlags where + parseJSON = withScientific "MessageFlags" $ \s -> + let i = round s + -- TODO check to see that we know about all the flags + -- if i /= (i .&. range) + -- range = sum $ fst <$> (discordTypeTable @MessageFlag) + in return $ MessageFlags (snd <$> filter (\(i',_) -> i .&. i' == i') discordTypeTable) + +-- | This is sent on the message object when the message is a response to an Interaction without an existing message (i.e., any non-component interaction). +data MessageInteraction = MessageInteraction + { messageInteractionId :: InteractionId -- ^ Id of the interaction + , messageInteractionType :: Integer -- ^ Type of the interaction (liekly always application command) + , messageInteractionName :: T.Text -- ^ Name of the interaction + , messageInteractionUser :: User -- ^ User who invoked the interaction + } deriving (Show, Read, Eq, Ord) + +instance ToJSON MessageInteraction where + toJSON MessageInteraction{..} = objectFromMaybes + [ "id" .== messageInteractionId + , "type" .== messageInteractionType + , "name" .== messageInteractionName + , "user" .== messageInteractionUser + ] + +instance FromJSON MessageInteraction where + parseJSON = withObject "MessageInteraction" $ \o -> + MessageInteraction <$> o .: "id" + <*> o .: "type" + <*> o .: "name" + <*> o .: "user" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Color.hs b/deps/discord-haskell/src/Discord/Internal/Types/Color.hs new file mode 100644 index 0000000..09f7890 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Color.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Data structures pertaining to Discord Colors +module Discord.Internal.Types.Color where + + +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) +import Data.Char (toLower) +import Data.Aeson +import Data.Data +import Control.Applicative (Alternative((<|>))) +import Data.Bits (Bits((.&.))) + + +import Discord.Internal.Types.Prelude (InternalDiscordEnum(..)) + +-- | Color names +-- Color is a bit of a mess on discord embeds. +-- I've here stolen the pallet list from https://gist.github.com/thomasbnt/b6f455e2c7d743b796917fa3c205f812 +-- +-- All discord embed color stuff is credited to +-- https://github.com/WarwickTabletop/tablebot/pull/34 +data DiscordColor + = -- | An RGB color with values in @[0..255]@ + DiscordColorRGB Integer Integer Integer + | DiscordColorDefault + | DiscordColorAqua + | DiscordColorDarkAqua + | DiscordColorGreen + | DiscordColorDarkGreen + | DiscordColorBlue + | DiscordColorDarkBlue + | DiscordColorPurple + | DiscordColorDarkPurple + | DiscordColorLuminousVividPink + | DiscordColorDarkVividPink + | DiscordColorGold + | DiscordColorDarkGold + | DiscordColorOrange + | DiscordColorDarkOrange + | DiscordColorRed + | DiscordColorDarkRed + | DiscordColorGray + | DiscordColorDarkGray + | DiscordColorDarkerGray + | DiscordColorLightGray + | DiscordColorNavy + | DiscordColorDarkNavy + | DiscordColorYellow + | DiscordColorDiscordWhite + | DiscordColorDiscordBlurple + | DiscordColorDiscordGrayple + | DiscordColorDiscordDarkButNotBlack + | DiscordColorDiscordNotQuiteBlack + | DiscordColorDiscordGreen + | DiscordColorDiscordYellow + | DiscordColorDiscordFuschia + | DiscordColorDiscordRed + | DiscordColorDiscordBlack + deriving (Show, Read, Eq, Ord, Data) + +-- | @hexToRGB@ attempts to convert a potential hex string into its decimal RGB +-- components. +hexToRGB :: String -> Maybe (Integer, Integer, Integer) +hexToRGB hex = do + let h = map toLower hex + r <- take2 h >>= toDec + g <- drop2 h >>= take2 >>= toDec + b <- drop2 h >>= drop2 >>= toDec + return (r, g, b) + where + take2 (a:b:_) = Just [a, b] + take2 _ = Nothing + drop2 (_ : _ : as) = Just as + drop2 _ = Nothing + toDec :: String -> Maybe Integer + toDec [s, u] = do + a <- charToDec s + b <- charToDec u + return $ a * 16 + b + toDec _ = Nothing + charToDec :: Char -> Maybe Integer + charToDec 'a' = Just 10 + charToDec 'b' = Just 11 + charToDec 'c' = Just 12 + charToDec 'd' = Just 13 + charToDec 'e' = Just 14 + charToDec 'f' = Just 15 + charToDec c = readMaybe [c] + +-- | @hexToDiscordColor@ converts a potential hex string into a DiscordColor, +-- evaluating to Default if it fails. +hexToDiscordColor :: String -> DiscordColor +hexToDiscordColor hex = + 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 +colorToInternal DiscordColorDefault = 0 +colorToInternal DiscordColorAqua = 1752220 +colorToInternal DiscordColorDarkAqua = 1146986 +colorToInternal DiscordColorGreen = 3066993 +colorToInternal DiscordColorDarkGreen = 2067276 +colorToInternal DiscordColorBlue = 3447003 +colorToInternal DiscordColorDarkBlue = 2123412 +colorToInternal DiscordColorPurple = 10181046 +colorToInternal DiscordColorDarkPurple = 7419530 +colorToInternal DiscordColorLuminousVividPink = 15277667 +colorToInternal DiscordColorDarkVividPink = 11342935 +colorToInternal DiscordColorGold = 15844367 +colorToInternal DiscordColorDarkGold = 12745742 +colorToInternal DiscordColorOrange = 15105570 +colorToInternal DiscordColorDarkOrange = 11027200 +colorToInternal DiscordColorRed = 15158332 +colorToInternal DiscordColorDarkRed = 10038562 +colorToInternal DiscordColorGray = 9807270 +colorToInternal DiscordColorDarkGray = 9936031 +colorToInternal DiscordColorDarkerGray = 8359053 +colorToInternal DiscordColorLightGray = 12370112 +colorToInternal DiscordColorNavy = 3426654 +colorToInternal DiscordColorDarkNavy = 2899536 +colorToInternal DiscordColorYellow = 16776960 +colorToInternal DiscordColorDiscordWhite = 16777215 +colorToInternal DiscordColorDiscordBlurple = 5793266 +colorToInternal DiscordColorDiscordGrayple = 10070709 +colorToInternal DiscordColorDiscordDarkButNotBlack = 2895667 +colorToInternal DiscordColorDiscordNotQuiteBlack = 2303786 +colorToInternal DiscordColorDiscordGreen = 5763719 +colorToInternal DiscordColorDiscordYellow = 16705372 +colorToInternal DiscordColorDiscordFuschia = 15418782 +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) + +instance InternalDiscordEnum DiscordColor where + discordTypeStartValue = DiscordColorDefault + fromDiscordType = fromIntegral . colorToInternal + discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map (fromConstrB (fromConstr (toConstr (0 :: Int)))) (dataTypeConstrs $ dataTypeOf t) + +instance ToJSON DiscordColor where + toJSON = toJSON . fromDiscordType + +instance FromJSON DiscordColor where + parseJSON = + withScientific + "DiscordColor" + ( \v -> + discordTypeParseJSON "DiscordColor" (Number v) + <|> ( case maybeInt v >>= Just . convertToRGB of + Nothing -> fail $ "could not parse discord color: " ++ show v + Just d -> return d + ) + ) + where + maybeInt i + | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Components.hs b/deps/discord-haskell/src/Discord/Internal/Types/Components.hs new file mode 100644 index 0000000..16bb0c6 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Components.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Message components +module Discord.Internal.Types.Components + ( ActionRow (..), + Button (..), + ButtonStyle (..), + mkButton, + SelectMenu (..), + mkSelectMenu, + SelectMenuData (..), + SelectOption (..), + mkSelectOption, + TextInput (..), + mkTextInput, + ) +where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Foldable (Foldable (toList)) +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Discord.Internal.Types.Emoji (Emoji) +import Discord.Internal.Types.Prelude (objectFromMaybes, (.==), (.=?), ChannelTypeOption) + +-- | Container for other message Components +data ActionRow = ActionRowButtons [Button] | ActionRowSelectMenu SelectMenu + deriving (Show, Read, Eq, Ord) + +instance FromJSON ActionRow where + parseJSON = + withObject + "ActionRow" + ( \cs -> do + t <- cs .: "type" :: Parser Int + case t of + 1 -> do + a <- cs .: "components" :: Parser Array + let a' = toList a + case a' of + [] -> return $ ActionRowButtons [] + (c : _) -> + withObject + "ActionRow item" + ( \v -> do + t' <- v .: "type" :: Parser Int + case t' of + 2 -> ActionRowButtons <$> mapM parseJSON a' + _ | t' `elem` [3, 5, 6, 7, 8] -> ActionRowSelectMenu <$> parseJSON c + _ -> fail $ "unknown component type: " ++ show t' + ) + c + _ -> fail $ "expected action row type (1), got: " ++ show t + ) + +instance ToJSON ActionRow where + toJSON (ActionRowButtons bs) = object [("type", Number 1), ("components", toJSON bs)] + toJSON (ActionRowSelectMenu bs) = object [("type", Number 1), ("components", toJSON [bs])] + +-- | Component type for a button, split into URL button and not URL button. +-- +-- Don't directly send button components - they need to be within an action row. +data Button + = Button + { -- | Dev indentifier + buttonCustomId :: T.Text, + -- | Whether the button is disabled + buttonDisabled :: Bool, + -- | What is the style of the button + buttonStyle :: ButtonStyle, + -- | What is the user-facing label of the button + buttonLabel :: Maybe T.Text, + -- | What emoji is displayed on the button + buttonEmoji :: Maybe Emoji + } + | ButtonUrl + { -- | The url for the button. If this is not a valid url, everything will + -- break + buttonUrl :: T.Text, + -- | Whether the button is disabled + buttonDisabled :: Bool, + -- | What is the user-facing label of the button + buttonLabel :: Maybe T.Text, + -- | What emoji is displayed on the button + buttonEmoji :: Maybe Emoji + } + deriving (Show, Read, Eq, Ord) + +-- | Takes the label and the custom id of the button that is to be generated. +mkButton :: T.Text -> T.Text -> Button +mkButton label customId = Button customId False ButtonStyleSecondary (Just label) Nothing + +instance FromJSON Button where + parseJSON = + withObject + "Button" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> do + disabled <- v .:? "disabled" .!= False + label <- v .:? "label" + partialEmoji <- v .:? "emoji" + style <- v .: "style" :: Parser Scientific + case style of + 5 -> + ButtonUrl + <$> v .: "url" + <*> return disabled + <*> return label + <*> return partialEmoji + _ -> + Button + <$> v .: "custom_id" + <*> return disabled + <*> parseJSON (Number style) + <*> return label + <*> return partialEmoji + _ -> fail "expected button type, got a different component" + ) + +instance ToJSON Button where + toJSON ButtonUrl {..} = + objectFromMaybes + [ "type" .== Number 2, + "style" .== Number 5, + "label" .=? buttonLabel, + "disabled" .== buttonDisabled, + "url" .== buttonUrl, + "emoji" .=? buttonEmoji + ] + toJSON Button {..} = + objectFromMaybes + [ "type" .== Number 2, + "style" .== buttonStyle, + "label" .=? buttonLabel, + "disabled" .== buttonDisabled, + "custom_id" .== buttonCustomId, + "emoji" .=? buttonEmoji + ] + +-- | Buttton colors. +data ButtonStyle + = -- | Blurple button + ButtonStylePrimary + | -- | Grey button + ButtonStyleSecondary + | -- | Green button + ButtonStyleSuccess + | -- | Red button + ButtonStyleDanger + deriving (Show, Read, Eq, Ord) + +instance FromJSON ButtonStyle where + parseJSON = + withScientific + "ButtonStyle" + ( \case + 1 -> return ButtonStylePrimary + 2 -> return ButtonStyleSecondary + 3 -> return ButtonStyleSuccess + 4 -> return ButtonStyleDanger + _ -> fail "unrecognised non-url button style" + ) + +instance ToJSON ButtonStyle where + toJSON ButtonStylePrimary = Number 1 + toJSON ButtonStyleSecondary = Number 2 + toJSON ButtonStyleSuccess = Number 3 + toJSON ButtonStyleDanger = Number 4 + +-- | Component type for a select menu. +-- +-- Don't directly send select menus - they need to be within an action row. +data SelectMenu = SelectMenu + { -- | Dev identifier + selectMenuCustomId :: T.Text, + -- | Whether the select menu is disabled + selectMenuDisabled :: Bool, + -- | What type this select menu is, and the data it can hold + selectMenuData :: SelectMenuData, + -- | Placeholder text if nothing is selected + selectMenuPlaceholder :: Maybe T.Text, + -- | Minimum number of values to select (def 1, min 0, max 25) + selectMenuMinValues :: Maybe Integer, + -- | Maximum number of values to select (def 1, max 25) + selectMenuMaxValues :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) + +-- | Takes the custom id and the options of the select menu that is to be +-- generated. +mkSelectMenu :: T.Text -> [SelectOption] -> SelectMenu +mkSelectMenu customId sos = SelectMenu customId False (SelectMenuDataText sos) Nothing Nothing Nothing + +instance FromJSON SelectMenu where + parseJSON = + withObject + "SelectMenu" + $ \v -> + do + SelectMenu + <$> v .: "custom_id" + <*> v .:? "disabled" .!= False + <*> parseJSON (Object v) + <*> v .:? "placeholder" + <*> v .:? "min_values" + <*> v .:? "max_values" + + +instance ToJSON SelectMenu where + toJSON SelectMenu {..} = + objectFromMaybes $ + [ "custom_id" .== selectMenuCustomId, + "disabled" .== selectMenuDisabled, + "placeholder" .=? selectMenuPlaceholder, + "min_values" .=? selectMenuMinValues, + "max_values" .=? selectMenuMaxValues + ] <> case selectMenuData of + SelectMenuDataText sos -> ["type" .== Number 3, "options" .== sos] + SelectMenuDataUser -> ["type" .== Number 5] + SelectMenuDataRole -> ["type" .== Number 6] + SelectMenuDataMentionable -> ["type" .== Number 7] + SelectMenuDataChannels ctos -> ["type" .== Number 8, "channel_types" .== ctos] + +data SelectMenuData = + SelectMenuDataText [SelectOption] -- ^ Text options + | SelectMenuDataUser -- ^ Users + | SelectMenuDataRole -- ^ Roles + | SelectMenuDataMentionable -- ^ Anything mentionable (users and roles) + | SelectMenuDataChannels [ChannelTypeOption] -- ^ Channels (of certain types) + deriving (Show, Read, Eq, Ord) + +instance FromJSON SelectMenuData where + parseJSON = + withObject "SelectMenuData" $ \v -> + do + t <- v .: "type" + case t::Int of + 3 -> SelectMenuDataText <$> v .: "options" + 5 -> pure SelectMenuDataUser + 6 -> pure SelectMenuDataRole + 7 -> pure SelectMenuDataMentionable + 8 -> SelectMenuDataChannels <$> v .: "channel_types" + _ -> fail ("unknown select menu data type: " <> show t) + +-- | A single option in a select menu. +data SelectOption = SelectOption + { -- | User facing option name + selectOptionLabel :: T.Text, + -- | Dev facing option value + selectOptionValue :: T.Text, + -- | additional description + selectOptionDescription :: Maybe T.Text, + -- | A partial emoji to show with the object (id, name, animated) + selectOptionEmoji :: Maybe Emoji, + -- | Use this value by default + selectOptionDefault :: Maybe Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Make a select option from the given label and value. +mkSelectOption :: T.Text -> T.Text -> SelectOption +mkSelectOption label value = SelectOption label value Nothing Nothing Nothing + +instance FromJSON SelectOption where + parseJSON = withObject "SelectOption" $ \o -> + SelectOption <$> o .: "label" + <*> o .: "value" + <*> o .:? "description" + <*> o .:? "emoji" + <*> o .:? "default" + +instance ToJSON SelectOption where + toJSON SelectOption {..} = + objectFromMaybes + [ "label" .== selectOptionLabel, + "value" .== selectOptionValue, + "description" .=? selectOptionDescription, + "emoji" .=? selectOptionEmoji, + "default" .=? selectOptionDefault + ] + +data TextInput = TextInput + { -- | Dev identifier + textInputCustomId :: T.Text, + -- | What style to use (short or paragraph) + textInputIsParagraph :: Bool, + -- | The label for this component + textInputLabel :: T.Text, + -- | The minimum input length for a text input (0-4000) + textInputMinLength :: Maybe Integer, + -- | The maximum input length for a text input (1-4000) + textInputMaxLength :: Maybe Integer, + -- | Whether this component is required to be filled + textInputRequired :: Bool, + -- | The prefilled value for this component (max 4000) + textInputValue :: T.Text, + -- | Placeholder text if empty (max 4000) + textInputPlaceholder :: T.Text + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON TextInput where + toJSON TextInput {..} = + objectFromMaybes + [ "type" .== Number 4, + "custom_id" .== textInputCustomId, + "style" .== (1 + fromEnum textInputIsParagraph), + "label" .== textInputLabel, + "min_length" .=? textInputMinLength, + "max_length" .=? textInputMaxLength, + "required" .== textInputRequired, + "value" .== textInputValue, + "placeholder" .== textInputPlaceholder + ] + +instance FromJSON TextInput where + parseJSON = withObject "TextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 4 -> + TextInput <$> o .: "custom_id" + <*> fmap (== (2 :: Int)) (o .:? "style" .!= 1) + <*> o .:? "label" .!= "" + <*> o .:? "min_length" + <*> o .:? "max_length" + <*> o .:? "required" .!= False + <*> o .:? "value" .!= "" + <*> 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/deps/discord-haskell/src/Discord/Internal/Types/Embed.hs b/deps/discord-haskell/src/Discord/Internal/Types/Embed.hs new file mode 100644 index 0000000..6700911 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Embed.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures pertaining to Discord Embed +module Discord.Internal.Types.Embed where + +import Data.Aeson +import Data.Time.Clock +import Data.Default (Default, def) +import qualified Data.Text as T +import qualified Data.ByteString as B +import Data.Functor ((<&>)) + +import Network.HTTP.Client.MultipartFormData (PartM, partFileRequestBody) +import Network.HTTP.Client (RequestBody(RequestBodyBS)) + +import Discord.Internal.Types.Color (DiscordColor) + +createEmbed :: CreateEmbed -> Embed +createEmbed CreateEmbed{..} = + let + emptyMaybe :: T.Text -> Maybe T.Text + emptyMaybe t = if T.null t then Nothing else Just t + + embedImageToUrl :: T.Text -> CreateEmbedImage -> T.Text + embedImageToUrl place cei = case cei of + CreateEmbedImageUrl t -> t + CreateEmbedImageUpload _ -> T.filter (/=' ') $ "attachment://" <> createEmbedTitle <> place <> ".png" + + embedAuthor = EmbedAuthor createEmbedAuthorName + (emptyMaybe createEmbedAuthorUrl) + (embedImageToUrl "author" <$> createEmbedAuthorIcon) + Nothing + embedImage = (embedImageToUrl "image" <$> createEmbedImage) <&> + \image -> EmbedImage image Nothing Nothing Nothing + embedThumbnail = (embedImageToUrl "thumbnail" <$> createEmbedThumbnail) <&> + \thumbnail -> EmbedThumbnail thumbnail Nothing Nothing Nothing + embedFooter = EmbedFooter createEmbedFooterText + (embedImageToUrl "footer" <$> createEmbedFooterIcon) + Nothing + + in Embed { embedAuthor = Just embedAuthor + , embedTitle = emptyMaybe createEmbedTitle + , embedUrl = emptyMaybe createEmbedUrl + , embedThumbnail = embedThumbnail + , embedDescription = emptyMaybe createEmbedDescription + , embedFields = createEmbedFields + , embedImage = embedImage + , embedFooter = Just embedFooter + , embedColor = createEmbedColor + , embedTimestamp = createEmbedTimestamp + + -- can't set these + , embedVideo = Nothing + , embedProvider = Nothing + } + +data CreateEmbed = CreateEmbed + { createEmbedAuthorName :: T.Text + , createEmbedAuthorUrl :: T.Text + , createEmbedAuthorIcon :: Maybe CreateEmbedImage + , createEmbedTitle :: T.Text + , createEmbedUrl :: T.Text + , createEmbedThumbnail :: Maybe CreateEmbedImage + , createEmbedDescription :: T.Text + , createEmbedFields :: [EmbedField] + , createEmbedImage :: Maybe CreateEmbedImage + , createEmbedFooterText :: T.Text + , createEmbedFooterIcon :: Maybe CreateEmbedImage + , createEmbedColor :: Maybe DiscordColor + , createEmbedTimestamp :: Maybe UTCTime + } deriving (Show, Read, Eq, Ord) + +data CreateEmbedImage = CreateEmbedImageUrl T.Text + | CreateEmbedImageUpload B.ByteString + deriving (Show, Read, Eq, Ord) + +instance Default CreateEmbed where + def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing Nothing Nothing + +-- | An embed attached to a message. +data Embed = Embed + { embedAuthor :: Maybe EmbedAuthor + , embedTitle :: Maybe T.Text -- ^ Title of the embed + , embedUrl :: Maybe T.Text -- ^ URL of embed + , embedThumbnail :: Maybe EmbedThumbnail -- ^ Thumbnail in top-right + , embedDescription :: Maybe T.Text -- ^ Description of embed + , embedFields :: [EmbedField] -- ^ Fields of the embed + , embedImage :: Maybe EmbedImage + , embedFooter :: Maybe EmbedFooter + , embedColor :: Maybe DiscordColor -- ^ The embed color + , embedTimestamp :: Maybe UTCTime -- ^ The time of the embed content + , embedVideo :: Maybe EmbedVideo -- ^ Only present for "video" types + , embedProvider :: Maybe EmbedProvider -- ^ Only present for "video" types + } deriving (Show, Read, Eq, Ord) + +-- TODO +instance ToJSON Embed where + toJSON Embed{..} = object + [ "author" .= embedAuthor + , "title" .= embedTitle + , "url" .= embedUrl + , "description" .= embedDescription + , "thumbnail" .= embedThumbnail + , "fields" .= embedFields + , "image" .= embedImage + , "footer" .= embedFooter + , "color" .= embedColor + , "timestamp" .= embedTimestamp + , "video" .= embedVideo + , "provider" .= embedProvider + ] + +instance FromJSON Embed where + parseJSON = withObject "embed" $ \o -> + Embed <$> o .:? "author" + <*> o .:? "title" + <*> o .:? "url" + <*> o .:? "thumbnail" + <*> o .:? "description" + <*> o .:? "fields" .!= [] + <*> o .:? "image" + <*> o .:? "footer" + <*> o .:? "color" + <*> o .:? "timestamp" + <*> o .:? "video" + <*> o .:? "provider" + + +data EmbedThumbnail = EmbedThumbnail + { embedThumbnailUrl :: T.Text + , embedThumbnailProxyUrl :: Maybe T.Text + , embedThumbnailHeight :: Maybe Integer + , embedThumbnailWidth :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedThumbnail where + toJSON (EmbedThumbnail a b c d) = object + [ "url" .= a + , "proxy_url" .= b + , "height" .= c + , "width" .= d + ] + +instance FromJSON EmbedThumbnail where + parseJSON = withObject "thumbnail" $ \o -> + EmbedThumbnail <$> o .: "url" + <*> o .:? "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +data EmbedVideo = EmbedVideo + { embedVideoUrl :: Maybe T.Text + , embedProxyUrl :: Maybe T.Text + , embedVideoHeight :: Maybe Integer + , embedVideoWidth :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedVideo where + toJSON (EmbedVideo a a' b c) = object + [ "url" .= a + , "height" .= b + , "width" .= c + , "proxy_url" .= a' + ] + +instance FromJSON EmbedVideo where + parseJSON = withObject "video" $ \o -> + EmbedVideo <$> o .:? "url" + <*> o .:? "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +data EmbedImage = EmbedImage + { embedImageUrl :: T.Text + , embedImageProxyUrl :: Maybe T.Text + , embedImageHeight :: Maybe Integer + , embedImageWidth :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedImage where + toJSON (EmbedImage a b c d) = object + [ "url" .= a + , "proxy_url" .= b + , "height" .= c + , "width" .= d + ] + +instance FromJSON EmbedImage where + parseJSON = withObject "image" $ \o -> + EmbedImage <$> o .: "url" + <*> o .:? "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +data EmbedProvider = EmbedProvider + { embedProviderName :: Maybe T.Text + , embedProviderUrl :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedProvider where + toJSON (EmbedProvider a b) = object + [ "name" .= a + , "url" .= b + ] + +instance FromJSON EmbedProvider where + parseJSON = withObject "provider" $ \o -> + EmbedProvider <$> o .:? "name" + <*> o .:? "url" + +data EmbedAuthor = EmbedAuthor + { embedAuthorName :: T.Text + , embedAuthorUrl :: Maybe T.Text + , embedAuthorIconUrl :: Maybe T.Text + , embedAuthorProxyIconUrl :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedAuthor where + toJSON (EmbedAuthor a b c d) = object + [ "name" .= a + , "url" .= b + , "icon_url" .= c + , "proxy_icon_url" .= d + ] + +instance FromJSON EmbedAuthor where + parseJSON = withObject "author" $ \o -> + EmbedAuthor <$> o .: "name" + <*> o .:? "url" + <*> o .:? "icon_url" + <*> o .:? "proxy_icon_url" + +data EmbedFooter = EmbedFooter + { embedFooterText :: T.Text + , embedFooterIconUrl :: Maybe T.Text + , embedFooterProxyIconUrl :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedFooter where + toJSON (EmbedFooter a b c) = object + [ "text" .= a + , "icon_url" .= b + , "proxy_icon_url" .= c + ] + +instance FromJSON EmbedFooter where + parseJSON = withObject "footer" $ \o -> + EmbedFooter <$> o .: "text" + <*> o .:? "icon_url" + <*> o .:? "proxy_icon_url" + +data EmbedField = EmbedField + { embedFieldName :: T.Text + , embedFieldValue :: T.Text + , embedFieldInline :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedField where + toJSON (EmbedField a b c) = object + [ "name" .= a + , "value" .= b + , "inline" .= c + ] + +instance FromJSON EmbedField where + parseJSON = withObject "field" $ \o -> + EmbedField <$> o .: "name" + <*> o .: "value" + <*> o .:? "inline" + + +maybeEmbed :: Maybe CreateEmbed -> [PartM IO] +maybeEmbed = + let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed{..} = [(T.filter (/=' ') $ createEmbedTitle<>n,c) | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png", createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png", createEmbedImage) + , ("footer.png", createEmbedFooterIcon) ]] + in maybe [] (map mkPart . uploads) diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs new file mode 100644 index 0000000..9023d4a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Emoji where + +import Data.Aeson +import Data.Data +import Data.Functor ((<&>)) +import Data.Text as T +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User + +-- | Represents an emoticon (emoji) +data Emoji = Emoji + { -- | The emoji id + emojiId :: Maybe EmojiId, + -- | The emoji name + emojiName :: T.Text, + -- | Roles the emoji is active for + emojiRoles :: Maybe [RoleId], + -- | User that created this emoji + emojiUser :: Maybe User, + -- | Whether this emoji is managed + emojiManaged :: Maybe Bool, + -- | Whether this emoji is animated + emojiAnimated :: Maybe Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Make an emoji with only a name +mkEmoji :: T.Text -> Emoji +mkEmoji t = Emoji Nothing t Nothing Nothing Nothing Nothing + +instance FromJSON Emoji where + parseJSON = withObject "Emoji" $ \o -> + Emoji <$> o .:? "id" + <*> o .: "name" + <*> o .:? "roles" + <*> o .:? "user" + <*> o .:? "managed" + <*> o .:? "animated" + +instance ToJSON Emoji where + toJSON Emoji {..} = + objectFromMaybes + [ "id" .=? emojiId, + "name" .== emojiName, + "roles" .=? emojiRoles, + "user" .=? emojiUser, + "managed" .=? emojiManaged, + "animated" .=? emojiAnimated + ] + +-- | Represents a pack of standard stickers. +data StickerPack = StickerPack + { -- | The id of the sticker pack + stickerPackId :: Snowflake, + -- | The stickers in the pack + stickerPackStickers :: [Sticker], + -- | The name of the sticker pack + stickerPackName :: T.Text, + -- | ID of the pack's SKU + stickerPackSKUId :: Snowflake, + -- | If of the sticker which is shown as the pack's icon + stickerPackCoverStickerId :: Maybe StickerId, + -- | The description of the sticker pack + stickerPackDescription :: T.Text, + -- | Id of the sticker pack's banner image + stickerPackBannerAssetId :: Maybe Snowflake + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON StickerPack where + parseJSON = withObject "StickerPack" $ \o -> + StickerPack <$> o .: "id" + <*> o .: "stickers" + <*> o .: "name" + <*> o .: "sku_id" + <*> o .:? "cover_sticker_id" + <*> o .: "description" + <*> o .:? "banner_asset_id" + +-- | A full sticker object +data Sticker = Sticker + { -- | The sticker's id. + stickerId :: StickerId, + -- | For standard stickers, the id of the pack. + stickerStickerPackId :: Maybe Snowflake, + -- | The sticker's name. + stickerName :: T.Text, + -- | The sticker's description. + stickerDescription :: Maybe T.Text, + -- | Autocomplete/suggestion tags for the sticker (max 200 characters total). + stickerTags :: [T.Text], + -- | Whether the sticker is standard or guild type. + stickerIsStandardType :: Bool, + -- | The sticker's format type. + stickerFormatType :: StickerFormatType, + -- | Whether this guild sticker can be used. + stickerAvailable :: Maybe Bool, + -- | What guild owns this sticker. + stickerGuildId :: Maybe GuildId, + -- | What user uploaded the guild sticker. + stickerUser :: Maybe User, + -- | A standard sticker's sort order in its pack. + stickerSortValue :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON Sticker where + parseJSON = withObject "Sticker" $ \o -> + Sticker <$> o .: "id" + <*> o .:? "pack_id" + <*> o .: "name" + <*> o .:? "description" + <*> ((o .: "tags") <&> T.splitOn "\n") + <*> ((o .: "type") <&> (== (1 :: Int))) + <*> o .: "format_type" + <*> o .:? "available" + <*> o .:? "guild_id" + <*> o .:? "user" + <*> o .:? "sort_value" + +-- | A simplified sticker object. +data StickerItem = StickerItem + { -- | The sticker's id. + stickerItemId :: StickerId, + -- | The sticker's name. + stickerItemName :: T.Text, + -- | The sticker's format type. + stickerItemFormatType :: StickerFormatType + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON StickerItem where + parseJSON = withObject "StickerItem" $ \o -> + StickerItem <$> o .: "id" + <*> o .: "name" + <*> o .: "format_type" + +instance ToJSON StickerItem where + toJSON StickerItem {..} = + object + [ ("id", toJSON stickerItemId), + ("name", toJSON stickerItemName), + ("format_type", toJSON stickerItemFormatType) + ] + +-- | The format of a sticker +data StickerFormatType + = StickerFormatTypePNG + | StickerFormatTypeAPNG + | StickerFormatTypeLOTTIE + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum StickerFormatType where + discordTypeStartValue = StickerFormatTypePNG + fromDiscordType StickerFormatTypePNG = 1 + fromDiscordType StickerFormatTypeAPNG = 2 + fromDiscordType StickerFormatTypeLOTTIE = 3 + +instance ToJSON StickerFormatType where + toJSON = toJSON . fromDiscordType + +instance FromJSON StickerFormatType where + parseJSON = discordTypeParseJSON "StickerFormatType" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Events.hs b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs new file mode 100644 index 0000000..d77cc96 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Data structures pertaining to gateway dispatch 'Event's +module Discord.Internal.Types.Events where + +import Prelude hiding (id) + +import Data.Time.ISO8601 (parseISO8601) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Network.Socket (HostName) + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Guild +import Discord.Internal.Types.User (User, GuildMember) +import Discord.Internal.Types.Interactions (Interaction) +import Discord.Internal.Types.Emoji (Emoji) +import Discord.Internal.Types.ScheduledEvents (ScheduledEvent) + + +-- | Represents possible events sent by discord. Detailed information can be found at <https://discord.com/developers/docs/topics/gateway>. +data Event = + -- | Contains the initial state information + Ready Int User [GuildUnavailable] T.Text HostName (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 + -- | 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 GuildCreateData + -- | 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 + -- | 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 [GuildUnavailable] T.Text HostName (Maybe Shard) PartialApplication + | InternalResumed [T.Text] + | InternalChannelCreate Channel + | InternalChannelUpdate Channel + | InternalChannelDelete Channel + | InternalThreadCreate Channel + | InternalThreadUpdate Channel + | InternalThreadDelete Channel + | InternalThreadListSync ThreadListSyncFields + | InternalThreadMembersUpdate ThreadMembersUpdateFields + | InternalChannelPinsUpdate ChannelId (Maybe UTCTime) + | InternalGuildCreate Guild GuildCreateData + | InternalGuildUpdate Guild + | InternalGuildDelete GuildUnavailable + | InternalGuildBanAdd GuildId User + | InternalGuildBanRemove GuildId User + | InternalGuildEmojiUpdate GuildId [Emoji] + | InternalGuildIntegrationsUpdate GuildId + | InternalGuildMemberAdd GuildId GuildMember + | InternalGuildMemberRemove GuildId User + | InternalGuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + | InternalGuildMemberChunk GuildId [GuildMember] + | InternalGuildRoleCreate GuildId Role + | InternalGuildRoleUpdate GuildId Role + | InternalGuildRoleDelete GuildId RoleId + | InternalMessageCreate Message + | InternalMessageUpdate ChannelId MessageId + | InternalMessageDelete ChannelId MessageId + | InternalMessageDeleteBulk ChannelId [MessageId] + | InternalMessageReactionAdd ReactionInfo + | InternalMessageReactionRemove ReactionInfo + | InternalMessageReactionRemoveAll ChannelId MessageId + | InternalMessageReactionRemoveEmoji ReactionRemoveInfo + | InternalPresenceUpdate PresenceInfo + | InternalTypingStart TypingInfo + | InternalUserUpdate User + | InternalInteractionCreate Interaction + -- | InternalVoiceStateUpdate + -- | InternalVoiceServerUpdate + | InternalUnknownEvent T.Text Object + deriving (Show, Eq, Read) + +-- | Structure containing partial information about an Application +data PartialApplication = PartialApplication + { partialApplicationID :: ApplicationId + , partialApplicationFlags :: Int + } deriving (Show, Eq, Read) + +instance FromJSON PartialApplication where + parseJSON = withObject "PartialApplication" (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") + +data GuildCreateData = GuildCreateData + { guildCreateJoinedAt :: !UTCTime + , guildCreateLarge :: !Bool + , guildCreateUnavailable :: !(Maybe Bool) + , guildCreateMemberCount :: !Int + -- , guildCreateVoiceStates + , guildCreateMembers :: ![GuildMember] + , guildCreateChannels :: ![Channel] + , guildCreateThreads :: ![Channel] + , guildCreatePresences :: ![PresenceInfo] + -- , guildStageInstances :: [StageI] + , guildCreateScheduledEvents :: ![ScheduledEvent] + } deriving (Show, Eq, Read) + +instance FromJSON GuildCreateData where + parseJSON = withObject "GuildCreateData" $ \o -> + GuildCreateData <$> o .: "joined_at" + <*> o .: "large" + <*> o .:? "unavailable" + <*> o .: "member_count" + <*> o .: "members" + <*> o .: "channels" + <*> o .: "threads" + <*> o .: "presences" + <*> o .: "guild_scheduled_events" + +-- | Structure containing information about a reaction +data ReactionInfo = ReactionInfo + { 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 + parseJSON = withObject "ReactionInfo" $ \o -> + ReactionInfo <$> o .: "user_id" + <*> o .:? "guild_id" + <*> o .: "channel_id" + <*> o .: "message_id" + <*> o .: "emoji" + +-- | Structure containing information about a reaction that has been removed +data ReactionRemoveInfo = ReactionRemoveInfo + { reactionRemoveChannelId :: ChannelId + , reactionRemoveGuildId :: GuildId + , reactionRemoveMessageId :: MessageId + , reactionRemoveEmoji :: Emoji + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ReactionRemoveInfo where + parseJSON = withObject "ReactionRemoveInfo" $ \o -> + ReactionRemoveInfo <$> o .: "guild_id" + <*> o .: "channel_id" + <*> o .: "message_id" + <*> o .: "emoji" + +-- | Structre containing typing status information +data TypingInfo = TypingInfo + { typingUserId :: UserId + , typingChannelId :: ChannelId + , typingTimestamp :: UTCTime + } deriving (Show, Read, Eq, Ord) + +instance FromJSON TypingInfo where + parseJSON = withObject "TypingInfo" $ \o -> + do cid <- o .: "channel_id" + uid <- o .: "user_id" + posix <- o .: "timestamp" + let utc = posixSecondsToUTCTime posix + pure (TypingInfo uid cid utc) + + + +-- | Convert ToJSON value to FromJSON value +reparse :: (ToJSON a, FromJSON b) => a -> Parser b +reparse val = case parseEither parseJSON $ toJSON val of + Left r -> fail r + Right b -> pure b + +-- | Remove the "wss://" and the trailing slash in a gateway URL, thereby returning +-- the hostname portion of the URL that we can connect to. +extractHostname :: String -> HostName +extractHostname ('w':'s':'s':':':'/':'/':rest) = extractHostname rest +extractHostname "/" = [] +extractHostname (a:b) = a:extractHostname b +extractHostname [] = [] + +-- | Parse an event from name and JSON data +eventParse :: T.Text -> Object -> Parser EventInternalParse +eventParse t o = case t of + "READY" -> InternalReady <$> o .: "v" + <*> o .: "user" + <*> o .: "guilds" + <*> o .: "session_id" + -- Discord can send us the resume gateway URL prefixed with "wss://", + -- and suffixed with a trailing slash. This is not a valid HostName, + -- so remove them both if they exist. + <*> (extractHostname <$> o .: "resume_gateway_url") + <*> o .: "shard" + <*> o .: "application" + "RESUMED" -> InternalResumed <$> o .: "_trace" + "CHANNEL_CREATE" -> InternalChannelCreate <$> reparse o + "CHANNEL_UPDATE" -> InternalChannelUpdate <$> reparse o + "CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o + "THREAD_CREATE" -> InternalThreadCreate <$> reparse o + "THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o + "THREAD_DELETE" -> InternalThreadDelete <$> reparse o + "THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o + "THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o + "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" + stamp <- o .:? "last_pin_timestamp" + let utc = stamp >>= parseISO8601 + pure (InternalChannelPinsUpdate id utc) + "GUILD_CREATE" -> InternalGuildCreate <$> reparse o <*> reparse o + "GUILD_UPDATE" -> InternalGuildUpdate <$> reparse o + "GUILD_DELETE" -> InternalGuildDelete <$> reparse o + "GUILD_BAN_ADD" -> InternalGuildBanAdd <$> o .: "guild_id" <*> o .: "user" + "GUILD_BAN_REMOVE" -> InternalGuildBanRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_EMOJI_UPDATE" -> InternalGuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" + "GUILD_INTEGRATIONS_UPDATE" -> InternalGuildIntegrationsUpdate <$> o .: "guild_id" + "GUILD_MEMBER_ADD" -> InternalGuildMemberAdd <$> o .: "guild_id" <*> reparse o + "GUILD_MEMBER_REMOVE" -> InternalGuildMemberRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_MEMBER_UPDATE" -> InternalGuildMemberUpdate <$> o .: "guild_id" + <*> o .: "roles" + <*> o .: "user" + <*> o .:? "nick" + "GUILD_MEMBERS_CHUNK" -> InternalGuildMemberChunk <$> o .: "guild_id" <*> o .: "members" + "GUILD_ROLE_CREATE" -> InternalGuildRoleCreate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_UPDATE" -> InternalGuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_DELETE" -> InternalGuildRoleDelete <$> o .: "guild_id" <*> o .: "role_id" + "MESSAGE_CREATE" -> InternalMessageCreate <$> reparse o + "MESSAGE_UPDATE" -> InternalMessageUpdate <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE" -> InternalMessageDelete <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE_BULK" -> InternalMessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" + "MESSAGE_REACTION_ADD" -> InternalMessageReactionAdd <$> reparse o + "MESSAGE_REACTION_REMOVE" -> InternalMessageReactionRemove <$> reparse o + "MESSAGE_REACTION_REMOVE_ALL" -> InternalMessageReactionRemoveAll <$> o .: "channel_id" + <*> o .: "message_id" + "MESSAGE_REACTION_REMOVE_EMOJI" -> InternalMessageReactionRemoveEmoji <$> reparse o + "PRESENCE_UPDATE" -> InternalPresenceUpdate <$> reparse o + "TYPING_START" -> InternalTypingStart <$> reparse o + "USER_UPDATE" -> InternalUserUpdate <$> reparse o + -- "VOICE_STATE_UPDATE" -> InternalVoiceStateUpdate <$> reparse o + -- "VOICE_SERVER_UPDATE" -> InternalVoiceServerUpdate <$> reparse o + "INTERACTION_CREATE" -> InternalInteractionCreate <$> reparse o + _other_event -> InternalUnknownEvent t <$> reparse o diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs new file mode 100644 index 0000000..a3b8f90 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures needed for interfacing with the Websocket +-- Gateway +module Discord.Internal.Types.Gateway where + +import System.Info + +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Aeson +import Data.Aeson.Types +import Data.Default (Default, def) +import Data.Maybe (fromMaybe) +import Data.Functor +import Text.Read (readMaybe) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Events +import Discord.Internal.Types.Guild (Activity (..)) + +-- | Messages that can be sent by gateway to the library +data GatewayReceivable + = Dispatch EventInternalParse Integer + | HeartbeatRequest Integer + | Reconnect + | InvalidSession Bool + | Hello Integer + | HeartbeatAck + | ParseError T.Text + deriving (Show, Eq, Read) + +-- | Sent to gateway by our library +data GatewaySendableInternal + = Heartbeat Integer + | Identify Auth GatewayIntent (Int, Int) + | Resume Auth T.Text Integer + deriving (Show, Read, Eq, Ord) + + +-- | 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 + , gatewayIntentBans :: Bool + , gatewayIntentEmojis :: Bool + , gatewayIntentIntegrations :: Bool + , gatewayIntentWebhooks :: Bool + , gatewayIntentInvites :: Bool + , gatewayIntentVoiceStates :: Bool + , gatewayIntentPresences :: Bool + , gatewayIntentMessageChanges :: Bool + , gatewayIntentMessageReactions :: Bool + , gatewayIntentMessageTyping :: Bool + , gatewayIntentDirectMessageChanges :: Bool + , gatewayIntentDirectMessageReactions :: Bool + , gatewayIntentDirectMessageTyping :: Bool + , gatewayIntentMessageContent :: Bool + } deriving (Show, Read, Eq, Ord) + +instance Default GatewayIntent where + def = GatewayIntent { gatewayIntentGuilds = True + , gatewayIntentMembers = False -- false + , gatewayIntentBans = True + , gatewayIntentEmojis = True + , gatewayIntentIntegrations = True + , gatewayIntentWebhooks = True + , gatewayIntentInvites = True + , gatewayIntentVoiceStates = True + , gatewayIntentPresences = False -- false + , gatewayIntentMessageChanges = True + , gatewayIntentMessageReactions = True + , gatewayIntentMessageTyping = True + , gatewayIntentDirectMessageChanges = True + , gatewayIntentDirectMessageReactions = True + , gatewayIntentDirectMessageTyping = True + , gatewayIntentMessageContent = True + } + +compileGatewayIntent :: GatewayIntent -> Int +compileGatewayIntent GatewayIntent{..} = + sum $ [ if on then flag else 0 + | (flag, on) <- [ ( 1, gatewayIntentGuilds) + , (2 ^ 1, gatewayIntentMembers) + , (2 ^ 2, gatewayIntentBans) + , (2 ^ 3, gatewayIntentEmojis) + , (2 ^ 4, gatewayIntentIntegrations) + , (2 ^ 5, gatewayIntentWebhooks) + , (2 ^ 6, gatewayIntentInvites) + , (2 ^ 7, gatewayIntentVoiceStates) + , (2 ^ 8, gatewayIntentPresences) + , (2 ^ 9, gatewayIntentMessageChanges) + , (2 ^ 10, gatewayIntentMessageReactions) + , (2 ^ 11, gatewayIntentMessageTyping) + , (2 ^ 12, gatewayIntentDirectMessageChanges) + , (2 ^ 13, gatewayIntentDirectMessageReactions) + , (2 ^ 14, gatewayIntentDirectMessageTyping) + , (2 ^ 15, gatewayIntentMessageContent) + ] + ] + +-- | Sent to gateway by a user +data GatewaySendable + = RequestGuildMembers RequestGuildMembersOpts + | UpdateStatus UpdateStatusOpts + | 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 + , updateStatusVoiceOptsIsMuted :: Bool + , updateStatusVoiceOptsIsDeaf :: Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Options for `UpdateStatus` +data UpdateStatusOpts = UpdateStatusOpts + { updateStatusOptsSince :: Maybe UTCTime + , updateStatusOptsGame :: Maybe Activity + , updateStatusOptsNewStatus :: UpdateStatusType + , updateStatusOptsAFK :: Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Possible values for `updateStatusOptsNewStatus` +data UpdateStatusType = UpdateStatusOnline + | UpdateStatusDoNotDisturb + | UpdateStatusAwayFromKeyboard + | UpdateStatusInvisibleOffline + | 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" + UpdateStatusDoNotDisturb -> "dnd" + UpdateStatusAwayFromKeyboard -> "idle" + UpdateStatusInvisibleOffline -> "invisible" + UpdateStatusOffline -> "offline" + +instance FromJSON GatewayReceivable where + parseJSON = withObject "payload" $ \o -> do + op <- o .: "op" :: Parser Int + case op of + 0 -> do etype <- o .: "t" + ejson <- o .: "d" + case ejson of + Object hm -> Dispatch <$> eventParse etype hm <*> o .: "s" + _other -> Dispatch (InternalUnknownEvent "Dispatch payload wasn't an object" o) + <$> o .: "s" + 1 -> HeartbeatRequest . fromMaybe 0 . readMaybe <$> o .: "d" + 7 -> pure Reconnect + 9 -> InvalidSession <$> o .: "d" + 10 -> do od <- o .: "d" + int <- od .: "heartbeat_interval" + pure (Hello int) + 11 -> pure HeartbeatAck + _ -> fail ("Unknown Receivable payload ID:" <> show op) + +-- instance FromJSON GatewaySendable where +-- parseJSON = withObject "payload" $ \o -> do +-- op <- o .: "op" :: Parser Int +-- case op of +-- 1 -> Heartbeat . fromMaybe 0 . readMaybe <$> o .: "d" +-- 2 -> do od <- o .: "d" +-- tok <- od .: "token" +-- compress <- od .:? "compress" .!= False +-- +-- _ -> fail ("Unknown Sendable payload ID:" <> show op) + +instance ToJSON GatewaySendableInternal where + toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ] + toJSON (Identify token intent shard) = object [ + "op" .= (2 :: Int) + , "d" .= object [ + "token" .= authToken token + , "intents" .= compileGatewayIntent intent + , "properties" .= object [ + "$os" .= os + , "$browser" .= ("discord-haskell" :: T.Text) + , "$device" .= ("discord-haskell" :: T.Text) + , "$referrer" .= ("" :: T.Text) + , "$referring_domain" .= ("" :: T.Text) + ] + , "compress" .= False + , "large_threshold" .= (50 :: Int) -- stop sending offline members over 50 + , "shard" .= shard + ] + ] + toJSON (Resume token session seqId) = object [ + "op" .= (6 :: Int) + , "d" .= object [ + "token" .= authToken token + , "session_id" .= session + , "seq" .= seqId + ] + ] + +instance ToJSON GatewaySendable where + toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [ + "op" .= (3 :: Int) + , "d" .= object [ + "since" .= (since <&> \s -> 1000 * utcTimeToPOSIXSeconds s) -- takes UTCTime and returns unix time (in milliseconds) + , "afk" .= afk + , "status" .= statusString status + , "game" .= (game <&> \a -> object [ + "name" .= activityName a + , "type" .= fromDiscordType (activityType a) + , "url" .= activityUrl a + ]) + ] + ] + toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) = + object [ + "op" .= (4 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "channel_id" .= channel + , "self_mute" .= mute + , "self_deaf" .= deaf + ] + ] + toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) = + object [ + "op" .= (8 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "query" .= query + , "limit" .= limit + ] + ] diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs new file mode 100644 index 0000000..5bddfaf --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Types relating to Discord Guilds (servers) +module Discord.Internal.Types.Guild where + +import Data.Time.Clock + +import Data.Aeson +import qualified Data.Text as T +import Data.Data (Data) +import Data.Default (Default(..)) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Color (DiscordColor) +import Discord.Internal.Types.User (User) +import Discord.Internal.Types.Emoji (Emoji, StickerItem) +import Data.List + +-- | Guilds in Discord represent a collection of users and channels into an isolated +-- "Server" +-- +-- https://discord.com/developers/docs/resources/guild#guild-object +data Guild = Guild + { guildId :: GuildId -- ^ Guild id + , guildName :: T.Text -- ^ Guild name (2 - 100 chars) + , guildIcon :: Maybe T.Text -- ^ Icon hash + , guildIconHash :: Maybe T.Text -- ^ Icon hash, when returned in template object + , guildSplash :: Maybe T.Text -- ^ Splash hash + , guildDiscoverySplash :: Maybe T.Text -- ^ Discovery splash hash + , guildOwner :: Maybe Bool -- ^ True is user is the owner of the guild + , guildOwnerId :: UserId -- ^ Guild owner id + , guildPermissions :: Maybe T.Text -- ^ Total permissions for the user in the guild + , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel + , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds + , guildWidgetEnabled :: Maybe Bool -- ^ Id of embedded channel + , guildWidgetChannelId :: Maybe ChannelId -- ^ Id of embedded channel + , guildVerificationLevel :: Integer -- ^ Level of verification + , guildNotification :: Integer -- ^ Level of default notifications + , guildExplicitFilterLevel :: Integer -- ^ Whose media gets scanned + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + , guildFeatures :: [T.Text] -- ^ Array of guild feature strings + , guildMultiFactAuth :: !Integer -- ^ MFA level for the guild + , guildApplicationId :: Maybe ApplicationId -- ^ Application id of the guild if bot created + , guildSystemChannelId :: Maybe ChannelId -- ^ Channel where guild notices such as welcome messages and boost events + , guildSystemChannelFlags :: Integer -- ^ Flags on the system channel + , guildRulesChannelId :: Maybe ChannelId -- ^ Id of channel with rules/guidelines + , guildMaxPresences :: Maybe Integer -- ^ Maximum number of prescences in the guild + , guildMaxMembers :: Maybe Integer -- ^ Maximum number of members in the guild + , guildVanityURL :: Maybe T.Text -- ^ Vanity url code for the guild + , guildDescription :: Maybe T.Text -- ^ Description of a commmunity guild + , guildBanner :: Maybe T.Text -- ^ Banner hash + , guildPremiumTier :: Integer -- ^ Premium tier (boost level) + , guildSubscriptionCount :: Maybe Integer -- ^ Number of boosts the guild has + , guildPreferredLocale :: T.Text -- ^ Preferred locale of a community server + , guildPublicUpdatesChannel :: Maybe ChannelId -- ^ Id of channel where admins and mods get updates + , guildMaxVideoUsers :: Maybe Integer -- ^ Maximum number of users in video channel + , guildApproxMemberCount :: Maybe Integer -- ^ Approximate number of members in the guild (GET /guilds/<id> endpoint when with_counts is true) + , guildApproxPresenceCount :: Maybe Integer -- ^ Approximate number of non-offline members in the guild (GET /guilds/<id> endpoint when with_counts is true) + -- welcome_screen + , guildNSFWLevel :: Integer -- ^ Guild NSFW level + -- stage_instances + , guildStickers :: Maybe [StickerItem] -- ^ Custom guild stickers + -- guild_scheduled_events + , guildPremiumBar :: Bool -- ^ Whether the guild has the boost progress bar enabled + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Guild where + parseJSON = withObject "Guild" $ \o -> + Guild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "icon_hash" + <*> o .:? "splash" + <*> o .:? "discovery_splash" + <*> o .:? "owner" + <*> o .: "owner_id" + <*> o .:? "permissions" + <*> o .:? "afk_channel_id" + <*> o .: "afk_timeout" + <*> o .:? "widget_enabled" + <*> o .:? "widget_channel_id" + <*> o .: "verification_level" + <*> o .: "default_message_notifications" + <*> o .: "explicit_content_filter" + <*> o .: "roles" + <*> o .: "emojis" + <*> o .: "features" + <*> o .: "mfa_level" + <*> o .:? "application_id" + <*> o .:? "system_channel_id" + <*> o .: "system_channel_flags" + <*> o .:? "rules_channel_id" + <*> o .:? "max_presences" + <*> o .:? "max_members" + <*> o .:? "vanity_url_code" + <*> o .:? "description" + <*> o .:? "banner" + <*> o .: "premium_tier" + <*> o .:? "premium_subscription_count" + <*> o .: "preferred_locale" + <*> o .:? "public_updates_channel_id" + <*> o .:? "max_video_channel_users" + <*> o .:? "approximate_member_count" + <*> o .:? "approximate_presence_count" + -- welcome_screen + <*> o .: "nsfw_level" + -- stage_instances + <*> o .:? "stickers" + <*> o .: "premium_progress_bar_enabled" + +newtype GuildUnavailable = GuildUnavailable + { idOnceAvailable :: GuildId + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildUnavailable where + parseJSON = withObject "GuildUnavailable" $ \o -> + GuildUnavailable <$> o .: "id" + +data PresenceInfo = PresenceInfo + { presenceUserId :: UserId + -- , presenceRoles :: [RoleId] + , presenceActivities :: Maybe [Activity] + , presenceGuildId :: Maybe GuildId + , presenceStatus :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON PresenceInfo where + parseJSON = withObject "PresenceInfo" $ \o -> + PresenceInfo <$> (o .: "user" >>= (.: "id")) + <*> o .: "activities" + <*> o .:? "guild_id" + <*> o .: "status" + +-- | Object for a single activity +-- +-- https://discord.com/developers/docs/topics/gateway#activity-object +-- +-- When setting a bot's activity, only the name, url, and type are sent - and +-- it seems that not many types are permitted either. +data Activity = + Activity + { activityName :: T.Text -- ^ Name of activity + , activityType :: ActivityType -- ^ Type of activity + , activityUrl :: Maybe T.Text -- ^ URL of the activity (only verified when streaming) + , activityCreatedAt :: Integer -- ^ unix time in milliseconds + , activityTimeStamps :: Maybe ActivityTimestamps -- ^ Start and end times + , activityApplicationId :: Maybe ApplicationId -- ^ Application of the activity + , activityDetails :: Maybe T.Text -- ^ Details of Activity + , activityState :: Maybe T.Text -- ^ State of the user's party + , activityEmoji :: Maybe Emoji -- ^ Simplified emoji object + , activityParty :: Maybe ActivityParty -- ^ Info for the current player's party + -- assets + -- secrets + , activityInstance :: Maybe Bool -- ^ Whether or not the activity is an instanced game session + , activityFlags :: Maybe Integer -- ^ The flags https://discord.com/developers/docs/topics/gateway#activity-object-activity-flags + , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence + } + deriving (Show, Read, Eq, Ord) + +instance Default Activity where + def = Activity "discord-haskell" ActivityTypeGame Nothing 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromJSON Activity where + parseJSON = withObject "Activity" $ \o -> do + Activity <$> o .: "name" + <*> o .: "type" + <*> o .:? "url" + <*> o .: "created_at" + <*> o .:? "timestamps" + <*> o .:? "application_id" + <*> o .:? "details" + <*> o .:? "state" + <*> o .:? "emoji" + <*> o .:? "party" + -- assets + -- secrets + <*> o .:? "instance" + <*> o .:? "flags" + <*> o .:? "buttons" + +data ActivityTimestamps = ActivityTimestamps + { activityTimestampsStart :: Maybe Integer -- ^ unix time in milliseconds + , activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityTimestamps where + parseJSON = withObject "ActivityTimestamps" $ \o -> + ActivityTimestamps <$> o .:? "start" + <*> o .:? "end" + +data ActivityParty = ActivityParty + { activityPartyId :: Maybe T.Text + , activityPartySize :: Maybe (Integer, Integer) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityParty where + parseJSON = withObject "ActivityParty" $ \o -> + ActivityParty <$> o .:? "id" + <*> o .:? "size" + +data ActivityButton = ActivityButton + { activityButtonLabel :: T.Text + , activityButtonUrl :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityButton where + parseJSON = withObject "ActivityButton" $ \o -> + ActivityButton <$> o .: "label" + <*> o .: "url" + +-- | To see what these look like, go to here: +-- https://discord.com/developers/docs/topics/gateway#activity-object-activity-types +data ActivityType = + ActivityTypeGame + | ActivityTypeStreaming + | ActivityTypeListening + | ActivityTypeWatching + | ActivityTypeCustom + | ActivityTypeCompeting + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ActivityType where + discordTypeStartValue = ActivityTypeGame + fromDiscordType ActivityTypeGame = 0 + fromDiscordType ActivityTypeStreaming = 1 + fromDiscordType ActivityTypeListening = 2 + fromDiscordType ActivityTypeWatching = 3 + fromDiscordType ActivityTypeCustom = 4 + fromDiscordType ActivityTypeCompeting = 5 + +instance FromJSON ActivityType where + parseJSON = discordTypeParseJSON "ActivityType" + +data PartialGuild = PartialGuild + { partialGuildId :: GuildId + , partialGuildName :: T.Text + , partialGuildIcon :: Maybe T.Text + , partialGuildOwner :: Bool + , partialGuildPermissions :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON PartialGuild where + parseJSON = withObject "PartialGuild" $ \o -> + PartialGuild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "owner" .!= False + <*> o .: "permissions" + + +-- | Roles represent a set of permissions attached to a group of users. Roles have unique +-- names, colors, and can be "pinned" to the side bar, causing their members to be listed separately. +-- Roles are unique per guild, and can have separate permission profiles for the global context +-- (guild) and channel context. +data Role = + Role { + roleId :: RoleId -- ^ The role id + , roleName :: T.Text -- ^ The role name + , roleColor :: DiscordColor -- ^ Integer representation of color code + , roleHoist :: Bool -- ^ If the role is pinned in the user listing + , rolePos :: Integer -- ^ Position of this role + , rolePerms :: RolePermissions -- ^ Permission bit set + , roleManaged :: Bool -- ^ Whether this role is managed by an integration + , roleMention :: Bool -- ^ Whether this role is mentionable + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Role where + parseJSON = withObject "Role" $ \o -> + Role <$> o .: "id" + <*> o .: "name" + <*> o .: "color" + <*> o .: "hoist" + <*> o .: "position" + <*> o .: "permissions" + <*> o .: "managed" + <*> o .: "mentionable" + + +-- | If there is no such role on the guild return nothing +-- otherwise return the role. Take the head of the list. List should always be one, because the ID is unique +roleIdToRole :: Guild -> RoleId -> Maybe Role +roleIdToRole g r = find(\x -> roleId x == r) $ guildRoles g + + +-- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added +data VoiceRegion = VoiceRegion + { voiceRegionId :: T.Text -- ^ Unique id of the region + , voiceRegionName :: T.Text -- ^ Name of the region + , voiceRegionVip :: Bool -- ^ True if this is a VIP only server + , voiceRegionOptimal :: Bool -- ^ True for the closest server to a client + , voiceRegionDeprecated :: Bool -- ^ Whether this is a deprecated region + , voiceRegionCustom :: Bool -- ^ Whether this is a custom region + } deriving (Show, Read, Eq, Ord) + +instance FromJSON VoiceRegion where + parseJSON = withObject "VoiceRegion" $ \o -> + VoiceRegion <$> o .: "id" + <*> o .: "name" + <*> o .: "vip" + <*> o .: "optimal" + <*> o .: "deprecated" + <*> o .: "custom" + +-- | Info about a Ban +data GuildBan = GuildBan + { guildBanReason :: T.Text + , guildBanUser :: User + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildBan where + parseJSON = withObject "GuildBan" $ \o -> GuildBan <$> o .: "reason" <*> o .: "user" + +-- | Represents a code to add a user to a guild +data Invite = Invite + { inviteCode :: T.Text -- ^ The invite code + , inviteGuildId :: Maybe GuildId -- ^ The guild the code will invite to + , inviteChannelId :: ChannelId -- ^ The channel the code will invite to + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Invite where + parseJSON = withObject "Invite" $ \o -> + Invite <$> o .: "code" + <*> (do g <- o .:? "guild" + case g of Just g2 -> g2 .: "id" + Nothing -> pure Nothing) + <*> ((o .: "channel") >>= (.: "id")) + +-- | Invite code with additional metadata +data InviteWithMeta = InviteWithMeta Invite InviteMeta + +instance FromJSON InviteWithMeta where + parseJSON ob = InviteWithMeta <$> parseJSON ob <*> parseJSON ob + +-- | Additional metadata about an invite. +data InviteMeta = InviteMeta + { inviteCreator :: User -- ^ The user that created the invite + , inviteUses :: Integer -- ^ Number of times the invite has been used + , inviteMax :: Integer -- ^ Max number of times the invite can be used + , inviteAge :: Integer -- ^ The duration (in seconds) after which the invite expires + , inviteTemp :: Bool -- ^ Whether this invite only grants temporary membership + , inviteCreated :: UTCTime -- ^ When the invite was created + , inviteRevoked :: Bool -- ^ If the invite is revoked + } deriving (Show, Read, Eq, Ord) + +instance FromJSON InviteMeta where + parseJSON = withObject "InviteMeta" $ \o -> + InviteMeta <$> o .: "inviter" + <*> o .: "uses" + <*> o .: "max_uses" + <*> o .: "max_age" + <*> o .: "temporary" + <*> o .: "created_at" + <*> o .: "revoked" + +-- | Represents the behavior of a third party account link. +data Integration = Integration + { integrationId :: !Snowflake -- ^ Integration id + , integrationName :: T.Text -- ^ Integration name + , integrationType :: T.Text -- ^ Integration type (Twitch, Youtube, ect.) + , integrationEnabled :: Bool -- ^ Is the integration enabled + , integrationSyncing :: Bool -- ^ Is the integration syncing + , integrationRole :: RoleId -- ^ Id the integration uses for "subscribers" + , integrationBehavior :: Integer -- ^ The behavior of expiring subscribers + , integrationGrace :: Integer -- ^ The grace period before expiring subscribers + , integrationOwner :: User -- ^ The user of the integration + , integrationAccount :: IntegrationAccount -- ^ The account the integration links to + , integrationSync :: UTCTime -- ^ When the integration was last synced + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Integration where + parseJSON = withObject "Integration" $ \o -> + Integration <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "enabled" + <*> o .: "syncing" + <*> o .: "role_id" + <*> o .: "expire_behavior" + <*> o .: "expire_grace_period" + <*> o .: "user" + <*> o .: "account" + <*> o .: "synced_at" + +-- | Represents a third party account link. +data IntegrationAccount = IntegrationAccount + { accountId :: T.Text -- ^ The id of the account. + , accountName :: T.Text -- ^ The name of the account. + } deriving (Show, Read, Eq, Ord) + +instance FromJSON IntegrationAccount where + parseJSON = withObject "IntegrationAccount" $ \o -> + IntegrationAccount <$> o .: "id" <*> o .: "name" + +-- | Represents an image to be used in third party sites to link to a discord channel +data GuildWidget = GuildWidget + { widgetEnabled :: Bool -- ^ Whether the widget is enabled + , widgetChannelId :: ChannelId -- ^ The widget channel id + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildWidget where + parseJSON = withObject "GuildWidget" $ \o -> + GuildWidget <$> o .: "enabled" <*> o .: "channel_id" + +instance ToJSON GuildWidget where + toJSON (GuildWidget enabled snowflake) = object + [ "enabled" .= enabled + , "channel_id" .= snowflake + ] diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs new file mode 100644 index 0000000..173f908 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs @@ -0,0 +1,665 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Interactions + ( Interaction (..), + ComponentData (..), + ApplicationCommandData (..), + OptionsData (..), + OptionDataSubcommandOrGroup (..), + OptionDataSubcommand (..), + OptionDataValue (..), + InteractionToken, + ResolvedData (..), + MemberOrUser (..), + InteractionResponse (..), + interactionResponseBasic, + InteractionResponseAutocomplete (..), + InteractionResponseMessage (..), + interactionResponseMessageBasic, + InteractionResponseMessageFlags (..), + InteractionResponseMessageFlag (..), + InteractionResponseModalData (..), + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Monad (join) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Bits (Bits (shift, (.|.))) +import Data.Foldable (Foldable (toList)) +import qualified Data.Text as T +import Discord.Internal.Types.ApplicationCommands (Choice, Number) +import Discord.Internal.Types.Channel (AllowedMentions, Attachment, Message) +import Discord.Internal.Types.Components (ActionRow, TextInput) +import Discord.Internal.Types.Embed (CreateEmbed, createEmbed) +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, ChannelId, GuildId, InteractionId, InteractionToken, MessageId, RoleId, Snowflake, UserId, objectFromMaybes, (.=?)) +import Discord.Internal.Types.User (GuildMember, User) + +-- | An interaction received from discord. +data Interaction + = InteractionComponent + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + componentData :: ComponentData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What message is associated with this interaction. + interactionMessage :: Message, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + | InteractionPing + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text + } + | InteractionApplicationCommand + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + applicationCommandData :: ApplicationCommandData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + | InteractionApplicationCommandAutocomplete + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + applicationCommandData :: ApplicationCommandData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + | InteractionModalSubmit + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + modalData :: ModalData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON Interaction where + parseJSON = + withObject + "Interaction" + ( \v -> do + iid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + cid <- v .:? "channel_id" + tok <- v .: "token" + version <- v .: "version" + glocale <- v .:? "guild_locale" + permissions <- v .:? "app_permissions" + t <- v .: "type" :: Parser Int + case t of + 1 -> return $ InteractionPing iid aid tok version permissions + 2 -> + InteractionApplicationCommand iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> return permissions + <*> v .: "locale" + <*> return glocale + 3 -> + InteractionComponent iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v .: "message" + <*> return permissions + <*> v .: "locale" + <*> return glocale + 4 -> + InteractionApplicationCommandAutocomplete iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> return permissions + <*> v .: "locale" + <*> return glocale + 5 -> + InteractionModalSubmit iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> return permissions + <*> v .: "locale" + <*> return glocale + _ -> fail "unknown interaction type" + ) + +newtype MemberOrUser = MemberOrUser (Either GuildMember User) + deriving (Show, Read, Eq, Ord) + +instance {-# OVERLAPPING #-} FromJSON MemberOrUser where + parseJSON = + withObject + "MemberOrUser" + ( \v -> MemberOrUser <$> (Left <$> v .: "member" <|> Right <$> v .: "user") + ) + +data ComponentData + = ButtonData + { -- | The unique id of the component (up to 100 characters). + componentDataCustomId :: T.Text + } + | SelectMenuData + { -- | The unique id of the component (up to 100 characters). + componentDataCustomId :: T.Text, + -- | Values for the select menu. + componentDataValues :: SelectMenuData + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ComponentData where + parseJSON = + withObject + "ComponentData" + ( \v -> do + cid <- v .: "custom_id" + t <- v .: "component_type" :: Parser Int + case t of + 2 -> return $ ButtonData cid + _ | t `elem` [3, 5, 6, 7, 8] -> + SelectMenuData cid + <$> parseJSON (toJSON v) + _ -> fail $ "unknown interaction data component type: " <> show t + ) + +data SelectMenuData + = SelectMenuDataText [T.Text] -- ^ The values of text chosen options + | SelectMenuDataUser [UserId] -- ^ The users selected + | SelectMenuDataRole [RoleId] -- ^ The roles selected + | SelectMenuDataMentionable [Snowflake] -- ^ The users or roles selected + | SelectMenuDataChannels [ChannelId] -- ^ The channels selected + deriving (Show, Read, Eq, Ord) + +instance FromJSON SelectMenuData where + parseJSON = + withObject + "SelectMenuData" + $ \v -> do + t <- v .: "component_type" :: Parser Int + let cons :: forall a. FromJSON a => ([a] -> SelectMenuData) -> Parser SelectMenuData + cons f = f <$> v .: "values" + case t of + 3 -> cons SelectMenuDataText + 5 -> cons SelectMenuDataUser + 6 -> cons SelectMenuDataRole + 7 -> cons SelectMenuDataMentionable + 8 -> cons SelectMenuDataChannels + _ -> fail $ "unknown SelectMenuData type: " <> show t + +data ApplicationCommandData + = ApplicationCommandDataUser + { -- | Id of the invoked command. + applicationCommandDataId :: ApplicationCommandId, + -- | Name of the invoked command. + applicationCommandDataName :: T.Text, + -- | The resolved data in the command. + resolvedData :: Maybe ResolvedData, + -- | The id of the user that is the target. + applicationCommandDataTargetUserId :: UserId + } + | ApplicationCommandDataMessage + { -- | Id of the invoked command. + applicationCommandDataId :: ApplicationCommandId, + -- | Name of the invoked command. + applicationCommandDataName :: T.Text, + -- | The resolved data in the command. + resolvedData :: Maybe ResolvedData, + -- | The id of the message that is the target. + applicationCommandDataTargetMessageId :: MessageId + } + | ApplicationCommandDataChatInput + { -- | Id of the invoked command. + applicationCommandDataId :: ApplicationCommandId, + -- | Name of the invoked command. + applicationCommandDataName :: T.Text, + -- | The resolved data in the command. + resolvedData :: Maybe ResolvedData, + -- | The options of the application command. + optionsData :: Maybe OptionsData + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ApplicationCommandData where + parseJSON = + withObject + "ApplicationCommandData" + ( \v -> do + aci <- v .: "id" + name <- v .: "name" + rd <- v .:? "resolved_data" + t <- v .: "type" :: Parser Int + case t of + 1 -> + ApplicationCommandDataChatInput aci name rd + <$> v .:? "options" + 2 -> + ApplicationCommandDataUser aci name rd + <$> v .: "target_id" + 3 -> + ApplicationCommandDataMessage aci name rd + <$> v .: "target_id" + _ -> fail "unknown interaction data component type" + ) + +-- | Either subcommands and groups, or values. +data OptionsData + = OptionsDataSubcommands [OptionDataSubcommandOrGroup] + | OptionsDataValues [OptionDataValue] + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionsData where + parseJSON = + withArray + "OptionsData" + ( \a -> do + let a' = toList a + case a' of + [] -> return $ OptionsDataValues [] + (v' : _) -> + withObject + "OptionsData item" + ( \v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then OptionsDataSubcommands <$> mapM parseJSON a' + else OptionsDataValues <$> mapM parseJSON a' + ) + v' + ) + +-- | Either a subcommand group or a subcommand. +data OptionDataSubcommandOrGroup + = OptionDataSubcommandGroup + { optionDataSubcommandGroupName :: T.Text, + optionDataSubcommandGroupOptions :: [OptionDataSubcommand], + optionDataSubcommandGroupFocused :: Bool + } + | OptionDataSubcommandOrGroupSubcommand OptionDataSubcommand + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionDataSubcommandOrGroup where + parseJSON = + withObject + "OptionDataSubcommandOrGroup" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + OptionDataSubcommandGroup + <$> v .: "name" + <*> v .: "options" + <*> v .:? "focused" .!= False + 1 -> OptionDataSubcommandOrGroupSubcommand <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) + +-- | Data for a single subcommand. +data OptionDataSubcommand = OptionDataSubcommand + { optionDataSubcommandName :: T.Text, + optionDataSubcommandOptions :: [OptionDataValue], + optionDataSubcommandFocused :: Bool + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionDataSubcommand where + parseJSON = + withObject + "OptionDataSubcommand" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + OptionDataSubcommand + <$> v .: "name" + <*> v .:? "options" .!= [] + <*> v .:? "focused" .!= False + _ -> fail "unexpected subcommand type" + ) + +-- | Data for a single value. +data OptionDataValue + = OptionDataValueString + { optionDataValueName :: T.Text, + optionDataValueString :: Either T.Text T.Text + } + | OptionDataValueInteger + { optionDataValueName :: T.Text, + optionDataValueInteger :: Either T.Text Integer + } + | OptionDataValueBoolean + { optionDataValueName :: T.Text, + optionDataValueBoolean :: Bool + } + | OptionDataValueUser + { optionDataValueName :: T.Text, + optionDataValueUser :: UserId + } + | OptionDataValueChannel + { optionDataValueName :: T.Text, + optionDataValueChannel :: ChannelId + } + | OptionDataValueRole + { optionDataValueName :: T.Text, + optionDataValueRole :: RoleId + } + | OptionDataValueMentionable + { optionDataValueName :: T.Text, + optionDataValueMentionable :: Snowflake + } + | OptionDataValueNumber + { optionDataValueName :: T.Text, + optionDataValueNumber :: Either T.Text Number + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionDataValue where + parseJSON = + withObject + "OptionDataValue" + ( \v -> do + name <- v .: "name" + focused <- v .:? "focused" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + OptionDataValueString name + <$> parseValue v focused + 4 -> + OptionDataValueInteger name + <$> parseValue v focused + 10 -> + OptionDataValueNumber name + <$> parseValue v focused + 5 -> + OptionDataValueBoolean name + <$> v .: "value" + 6 -> + OptionDataValueUser name + <$> v .: "value" + 7 -> + OptionDataValueChannel name + <$> v .: "value" + 8 -> + OptionDataValueRole name + <$> v .: "value" + 9 -> + OptionDataValueMentionable name + <$> v .: "value" + _ -> fail $ "unexpected interaction data application command option value type: " ++ show t + ) + +data ModalData = ModalData + { -- | The unique id of the component (up to 100 characters). + modalDataCustomId :: T.Text, + -- | Components from the modal. + modalDataComponents :: [TextInput] + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ModalData where + parseJSON = + withObject + "ModalData" + ( \v -> + ModalData <$> v .: "custom_id" + <*> ((v .: "components") >>= (join <$>) . mapM getTextInput) + ) + where + getTextInput :: Value -> Parser [TextInput] + getTextInput = withObject "ModalData.TextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 1 -> o .: "components" + _ -> fail $ "expected action row type (1), got: " ++ show t + +parseValue :: (FromJSON a) => Object -> Bool -> Parser (Either T.Text a) +parseValue o True = Left <$> o .: "value" +parseValue o False = Right <$> o .: "value" + +-- resolved data -- this should be formalised and integrated, instead of being +-- left as values + +-- | I'm not sure what this stuff is, so you're on your own. +-- +-- It's not worth the time working out how to create this stuff. +-- If you need to extract from these values, check out the link below. +-- +-- https://discord.com/developers/docs/interactions/receiving-and-responding#interaction-object-resolved-data-structure +data ResolvedData = ResolvedData + { resolvedDataUsers :: Maybe Value, + resolvedDataMembers :: Maybe Value, + resolvedDataRoles :: Maybe Value, + resolvedDataChannels :: Maybe Value, + resolvedDataMessages :: Maybe Value, + resolvedDataAttachments :: Maybe Value + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON ResolvedData where + toJSON ResolvedData {..} = + objectFromMaybes + [ "users" .=? resolvedDataUsers, + "members" .=? resolvedDataMembers, + "roles" .=? resolvedDataRoles, + "channels" .=? resolvedDataChannels, + "messages" .=? resolvedDataMessages, + "attachments" .=? resolvedDataAttachments + ] + +instance FromJSON ResolvedData where + parseJSON = + withObject + "ResolvedData" + ( \v -> + ResolvedData + <$> v .:? "users" + <*> v .:? "members" + <*> v .:? "roles" + <*> v .:? "channels" + <*> v .:? "messages" + <*> v .:? "attachments" + ) + +-- | The data to respond to an interaction with. Unless specified otherwise, you +-- only have three seconds to reply to an interaction before a failure state is +-- given. +data InteractionResponse + = -- | ACK a Ping + InteractionResponsePong + | -- | Respond to an interaction with a message + InteractionResponseChannelMessage InteractionResponseMessage + | -- | ACK an interaction and edit a response later (use `CreateFollowupInteractionMessage` and `InteractionResponseMessage` to do so). User sees loading state. + InteractionResponseDeferChannelMessage + | -- | for components, ACK an interaction and edit the original message later; the user does not see a loading state. + InteractionResponseDeferUpdateMessage + | -- | for components, edit the message the component was attached to + InteractionResponseUpdateMessage InteractionResponseMessage + | -- | respond to an autocomplete interaction with suggested choices + InteractionResponseAutocompleteResult InteractionResponseAutocomplete + | -- | respond with a popup modal + InteractionResponseModal InteractionResponseModalData + deriving (Show, Read, Eq, Ord) + +-- | A basic interaction response, sending back the given text. +interactionResponseBasic :: T.Text -> InteractionResponse +interactionResponseBasic t = InteractionResponseChannelMessage (interactionResponseMessageBasic t) + +instance ToJSON InteractionResponse where + toJSON InteractionResponsePong = object [("type", Number 1)] + toJSON InteractionResponseDeferChannelMessage = object [("type", Number 5)] + toJSON InteractionResponseDeferUpdateMessage = object [("type", Number 6)] + toJSON (InteractionResponseChannelMessage ms) = object [("type", Number 4), ("data", toJSON ms)] + toJSON (InteractionResponseUpdateMessage ms) = object [("type", Number 7), ("data", toJSON ms)] + toJSON (InteractionResponseAutocompleteResult ms) = object [("type", Number 8), ("data", toJSON ms)] + toJSON (InteractionResponseModal ms) = object [("type", Number 9), ("data", toJSON ms)] + +data InteractionResponseAutocomplete + = InteractionResponseAutocompleteString [Choice T.Text] + | InteractionResponseAutocompleteInteger [Choice Integer] + | InteractionResponseAutocompleteNumber [Choice Number] + deriving (Show, Read, Eq, Ord) + +instance ToJSON InteractionResponseAutocomplete where + toJSON (InteractionResponseAutocompleteString cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteInteger cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteNumber cs) = object [("choices", toJSON cs)] + +-- | A cut down message structure. +data InteractionResponseMessage = InteractionResponseMessage + { interactionResponseMessageTTS :: Maybe Bool, + interactionResponseMessageContent :: Maybe T.Text, + interactionResponseMessageEmbeds :: Maybe [CreateEmbed], + interactionResponseMessageAllowedMentions :: Maybe AllowedMentions, + interactionResponseMessageFlags :: Maybe InteractionResponseMessageFlags, + interactionResponseMessageComponents :: Maybe [ActionRow], + interactionResponseMessageAttachments :: Maybe [Attachment] + } + deriving (Show, Read, Eq, Ord) + +-- | A basic interaction response, sending back the given text. This is +-- effectively a helper function. +interactionResponseMessageBasic :: T.Text -> InteractionResponseMessage +interactionResponseMessageBasic t = InteractionResponseMessage Nothing (Just t) Nothing Nothing Nothing Nothing Nothing + +instance ToJSON InteractionResponseMessage where + toJSON InteractionResponseMessage {..} = + objectFromMaybes + [ "tts" .=? interactionResponseMessageTTS, + "content" .=? interactionResponseMessageContent, + "embeds" .=? ((createEmbed <$>) <$> interactionResponseMessageEmbeds), + "allowed_mentions" .=? interactionResponseMessageAllowedMentions, + "flags" .=? interactionResponseMessageFlags, + "components" .=? interactionResponseMessageComponents, + "attachments" .=? interactionResponseMessageAttachments + ] + +-- | Types of flags to attach to the interaction message. +-- +-- Currently the only flag is EPHERMERAL, which means only the user can see the +-- message. +data InteractionResponseMessageFlag = InteractionResponseMessageFlagEphermeral + deriving (Show, Read, Eq, Ord) + +newtype InteractionResponseMessageFlags = InteractionResponseMessageFlags [InteractionResponseMessageFlag] + deriving (Show, Read, Eq, Ord) + +instance Enum InteractionResponseMessageFlag where + fromEnum InteractionResponseMessageFlagEphermeral = 1 `shift` 6 + toEnum i + | i == 1 `shift` 6 = InteractionResponseMessageFlagEphermeral + | otherwise = error $ "could not find InteractionCallbackDataFlag `" ++ show i ++ "`" + +instance ToJSON InteractionResponseMessageFlags where + toJSON (InteractionResponseMessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) + +data InteractionResponseModalData = InteractionResponseModalData + { interactionResponseModalCustomId :: T.Text, + interactionResponseModalTitle :: T.Text, + interactionResponseModalComponents :: [TextInput] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON InteractionResponseModalData where + toJSON InteractionResponseModalData {..} = + object + [ ("custom_id", toJSON interactionResponseModalCustomId), + ("title", toJSON interactionResponseModalTitle), + ("components", toJSON $ map (\ti -> object [("type", Number 1), ("components", toJSON [ti])]) interactionResponseModalComponents) + ] diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs new file mode 100644 index 0000000..fd49a15 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Provides base types and utility functions needed for modules in Discord.Internal.Types +module Discord.Internal.Types.Prelude + ( Auth (..) + , authToken + + , Snowflake (..) + , snowflakeCreationDate + + , RolePermissions (..) + + , DiscordId (..) + , ChannelId + , StageId + , GuildId + , MessageId + , AttachmentId + , EmojiId + , StickerId + , UserId + , RoleId + , IntegrationId + , WebhookId + , ParentId + , ApplicationId + , ApplicationCommandId + , InteractionId + , ScheduledEventId + , ScheduledEventEntityId + + , DiscordToken (..) + , InteractionToken + , WebhookToken + + , Shard + , epochTime + + , InternalDiscordEnum (..) + + , Base64Image (..) + , getMimeType + + , (.==) + , (.=?) + , AesonKey + , objectFromMaybes + + , ChannelTypeOption (..) + ) + + where + +import Data.Bifunctor (first) +import Data.Bits (Bits(shiftR)) +import Data.Data (Data (dataTypeOf), dataTypeConstrs, fromConstr) +import Data.Word (Word64) +import Data.Maybe (catMaybes) +import Text.Read (readMaybe) + +import Data.Aeson.Types +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Web.Internal.HttpApiData + +import qualified Data.ByteString as B +import qualified Data.Text as T + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#endif + +-- | Authorization token for the Discord API +newtype Auth = Auth T.Text + deriving (Show, Read, Eq, Ord) + + +-- | Get the raw token formatted for use with the websocket gateway +authToken :: Auth -> T.Text +authToken (Auth tok) = let token = T.strip tok + bot = if "Bot " `T.isPrefixOf` token then "" else "Bot " + in bot <> token + +-- | A unique integer identifier. Can be used to calculate the creation date of an entity. +newtype Snowflake = Snowflake { unSnowflake :: Word64 } + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) + +instance Show Snowflake where + show (Snowflake a) = show a + +instance Read Snowflake where + readsPrec p = fmap (first Snowflake) . readsPrec p + +instance ToJSON Snowflake where + toJSON (Snowflake snowflake) = String . T.pack $ show snowflake + +instance FromJSON Snowflake where + parseJSON = + withText + "Snowflake" + ( \snowflake -> + case readMaybe (T.unpack snowflake) of + Nothing -> fail "null snowflake" + (Just i) -> pure i + ) + +instance ToHttpApiData Snowflake where + toUrlPiece = T.pack . show + +newtype RolePermissions = RolePermissions { getRolePermissions :: Integer } + deriving (Eq, Ord, Num, Bits, Enum, Real, Integral) + +instance Read RolePermissions where + readsPrec p = fmap (first RolePermissions) . readsPrec p + +instance ToJSON RolePermissions where + toJSON = toJSON . getRolePermissions + +-- In v8 and above, all permissions are serialized as strings. +-- See https://discord.com/developers/docs/topics/permissions#permissions. +instance FromJSON RolePermissions where + parseJSON = withText "RolePermissions" $ + \text -> case readMaybe (T.unpack text) of + Just perms -> pure $ RolePermissions perms + Nothing -> fail "invalid role permissions integer string" + +instance Show RolePermissions where + show = show . getRolePermissions + +newtype DiscordId a = DiscordId { unId :: Snowflake } + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) + +instance Show (DiscordId a) where + show = show . unId + +instance Read (DiscordId a) where + readsPrec p = fmap (first DiscordId) . readsPrec p + +instance ToJSON (DiscordId a) where + toJSON = toJSON . unId + +instance FromJSON (DiscordId a) where + parseJSON = fmap DiscordId . parseJSON + +instance ToHttpApiData (DiscordId a) where + toUrlPiece = T.pack . show + +data ChannelIdType +type ChannelId = DiscordId ChannelIdType + +data StageIdType +type StageId = DiscordId StageIdType + +data GuildIdType +type GuildId = DiscordId GuildIdType + +data MessageIdType +type MessageId = DiscordId MessageIdType + +data AttachmentIdType +type AttachmentId = DiscordId AttachmentIdType + +data EmojiIdType +type EmojiId = DiscordId EmojiIdType + +data StickerIdType +type StickerId = DiscordId StickerIdType + +data UserIdType +type UserId = DiscordId UserIdType + +data RoleIdType +type RoleId = DiscordId RoleIdType + +data IntegrationIdType +type IntegrationId = DiscordId IntegrationIdType + +data WebhookIdType +type WebhookId = DiscordId WebhookIdType + +data ParentIdType +type ParentId = DiscordId ParentIdType + +data ApplicationIdType +type ApplicationId = DiscordId ApplicationIdType + +data ApplicationCommandIdType +type ApplicationCommandId = DiscordId ApplicationCommandIdType + +data InteractionIdType +type InteractionId = DiscordId InteractionIdType + +data ScheduledEventIdType +type ScheduledEventId = DiscordId ScheduledEventIdType + +data ScheduledEventEntityIdType +type ScheduledEventEntityId = DiscordId ScheduledEventEntityIdType + +newtype DiscordToken a = DiscordToken { unToken :: T.Text } + deriving (Ord, Eq) + +instance Show (DiscordToken a) where + show = show . unToken + +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. +snowflakeCreationDate :: Snowflake -> UTCTime +snowflakeCreationDate x = posixSecondsToUTCTime . realToFrac + $ 1420070400 + quot (shiftR x 22) 1000 + +-- | Default timestamp +epochTime :: UTCTime +epochTime = posixSecondsToUTCTime 0 + +{- + +InternalDiscordEnum is a hack-y typeclass, but it's the best solution overall. +The best we can do is prevent the end-user from seeing this. + +typeclass Bounded (minBound + maxBound) could replace discordTypeStartValue, but +it can't derive instances for types like DiscordColor, which have simple sum types involved. + +typeclass Enum (toEnum + fromEnum) requires defining both A->Int and Int->A. +If we handle both at once (with an inline map), it's no longer typesafe. + +External packages exist, but bloat our dependencies + +-} +class Data a => InternalDiscordEnum a where + discordTypeStartValue :: a + fromDiscordType :: a -> Int + discordTypeTable :: [(Int, a)] + discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map fromConstr (dataTypeConstrs $ dataTypeOf t) + + discordTypeParseJSON :: String -> Value -> Parser a + discordTypeParseJSON name = + withScientific + name + ( \i -> do + case maybeInt i >>= (`lookup` discordTypeTable) of + Nothing -> fail $ "could not parse type: " ++ show i + Just d -> return d + ) + where + maybeInt i + | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing + +-- Aeson 2.0 uses KeyMaps with a defined Key type for its objects. Aeson up to +-- 1.5 uses HashMaps with Text for the key. Both types have an IsString instance. +-- To keep our version bounds as loose as possible while the Haskell ecosystem +-- (and thus our users) switch over to Aeson 2.0, we use some CPP to define a +-- AesonKey as an alias. +#if MIN_VERSION_aeson(2, 0, 0) +type AesonKey = Key.Key +#else +type AesonKey = T.Text +#endif + + +(.==) :: ToJSON a => AesonKey -> a -> Maybe Pair +k .== v = Just (k .= v) + +(.=?) :: ToJSON a => AesonKey -> Maybe a -> Maybe Pair +k .=? (Just v) = Just (k .= v) +_ .=? Nothing = Nothing + +objectFromMaybes :: [Maybe Pair] -> Value +objectFromMaybes = object . catMaybes + + +-- | @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 + +-- | The different channel types. Used for application commands and components. +-- +-- https://discord.com/developers/docs/resources/channel#channel-object-channel-types +data ChannelTypeOption + = -- | A text channel in a server. + ChannelTypeOptionGuildText + | -- | A direct message between users. + ChannelTypeOptionDM + | -- | A voice channel in a server. + ChannelTypeOptionGuildVoice + | -- | A direct message between multiple users. + ChannelTypeOptionGroupDM + | -- | An organizational category that contains up to 50 channels. + ChannelTypeOptionGuildCategory + | -- | A channel that users can follow and crosspost into their own server. + ChannelTypeOptionGuildNews + | -- | A channel in which game developers can sell their game on discord. + ChannelTypeOptionGuildStore + | -- | A temporary sub-channel within a guild_news channel. + ChannelTypeOptionGuildNewsThread + | -- | A temporary sub-channel within a guild_text channel. + ChannelTypeOptionGuildPublicThread + | -- | A temporary sub-channel within a GUILD_TEXT channel that is only + -- viewable by those invited and those with the MANAGE_THREADS permission + ChannelTypeOptionGuildPrivateThread + | -- | A voice channel for hosting events with an audience. + ChannelTypeOptionGuildStageVoice + deriving (Show, Read, Data, Eq, Ord) + +instance InternalDiscordEnum ChannelTypeOption where + discordTypeStartValue = ChannelTypeOptionGuildText + fromDiscordType ChannelTypeOptionGuildText = 0 + fromDiscordType ChannelTypeOptionDM = 1 + fromDiscordType ChannelTypeOptionGuildVoice = 2 + fromDiscordType ChannelTypeOptionGroupDM = 3 + fromDiscordType ChannelTypeOptionGuildCategory = 4 + fromDiscordType ChannelTypeOptionGuildNews = 5 + fromDiscordType ChannelTypeOptionGuildStore = 6 + fromDiscordType ChannelTypeOptionGuildNewsThread = 10 + fromDiscordType ChannelTypeOptionGuildPublicThread = 11 + fromDiscordType ChannelTypeOptionGuildPrivateThread = 12 + fromDiscordType ChannelTypeOptionGuildStageVoice = 13 + +instance ToJSON ChannelTypeOption where + toJSON = toJSON . fromDiscordType + +instance FromJSON ChannelTypeOption where + parseJSON = discordTypeParseJSON "ChannelTypeOption" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs new file mode 100644 index 0000000..3044e9e --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs @@ -0,0 +1,119 @@ +module Discord.Internal.Types.RolePermissions + ( PermissionFlag (..), + hasRolePermissions, + hasRolePermission, + newRolePermissions, + newRolePermission, + setRolePermissions, + setRolePermission, + clearRolePermissions, + clearRolePermission, + hasGuildMemberPermission, + ) +where + +import Data.Bits (Bits (complement, shift, (.&.), (.|.))) +import Discord.Internal.Types.Guild + ( Guild, + Role (rolePerms), + roleIdToRole, + ) +import Discord.Internal.Types.Prelude (RolePermissions) +import Discord.Internal.Types.User (GuildMember (memberRoles)) + +data PermissionFlag + = CREATE_INSTANT_INVITE + | KICK_MEMBERS + | BAN_MEMBERS + | ADMINISTRATOR + | MANAGE_CHANNELS + | MANAGE_GUILD + | ADD_REACTIONS + | VIEW_AUDIT_LOG + | PRIORITY_SPEAKER + | STREAM + | VIEW_CHANNEL + | SEND_MESSAGES + | SEND_TTS_MESSAGES + | MANAGE_MESSAGES + | EMBED_LINKS + | ATTACH_FILES + | READ_MESSAGE_HISTORY + | MENTION_EVERYONE + | USE_EXTERNAL_EMOJIS + | VIEW_GUILD_INSIGHT + | CONNECT + | SPEAK + | MUTE_MEMBERS + | DEAFEN_MEMBERS + | MOVE_MEMBERS + | USE_VAD + | CHANGE_NICKNAME + | MANAGE_NICKNAMES + | MANAGE_ROLES + | MANAGE_WEBHOOKS + | MANAGE_EMOJIS_AND_STICKERS + | USE_APPLICATION_COMMANDS + | REQUEST_TO_SPEAK + | MANAGE_EVENTS + | MANAGE_THREADS + | CREATE_PUBLIC_THREADS + | CREATE_PRIVATE_THREADS + | USE_EXTERNAL_STICKERS + | SEND_MESSAGES_IN_THREADS + | USE_EMBEDDED_ACTIVITIES + | MODERATE_MEMBERS + deriving (Eq, Ord, Enum, Show) + +permissionBits :: PermissionFlag -> RolePermissions +permissionBits p = shift 1 (fromEnum p) + +-- | Check if a given role has all the permissions +hasRolePermissions :: [PermissionFlag] -> RolePermissions -> Bool +hasRolePermissions permissions rolePermissions = (.&.) combinedPermissions rolePermissions == combinedPermissions + where + combinedPermissions = combinePermissions permissions + +-- | Check if a given role has the permission +hasRolePermission :: PermissionFlag -> RolePermissions -> Bool +hasRolePermission p r = (.&.) (permissionBits p) r > 0 + +-- | Replace a users rolePerms +-- with a complete new set of permissions +newRolePermissions :: [PermissionFlag] -> RolePermissions +newRolePermissions = combinePermissions + +-- | Get the RolePermissions of a single PermissionFlag +newRolePermission :: PermissionFlag -> RolePermissions +newRolePermission = permissionBits + +-- | Update RolePermissions with new permissions +setRolePermissions :: [PermissionFlag] -> RolePermissions -> RolePermissions +setRolePermissions p r = combinePermissions p .|. r + +-- | Unset Permissions from RolePermissions +clearRolePermissions :: [PermissionFlag] -> RolePermissions -> RolePermissions +clearRolePermissions p r = (complement . combinePermissions) p .&. r + +-- | Set a certain permission flag +-- This method doesn't lose the other already present permissions +setRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions +setRolePermission p = (.|.) (permissionBits p) + +-- | Remove a permission from a user by clearing the bit +clearRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions +clearRolePermission p = (.&.) (complement . permissionBits $ p) + +combinePermissions :: [PermissionFlag] -> RolePermissions +combinePermissions = foldr ((.|.) . permissionBits) 0 + +-- | Check if any Role of an GuildMember has the needed permission +-- If the result of roleIdToRole is Nothing, it prepends a "False" +-- Otherwise it checks for the needed permission +hasGuildMemberPermission :: Guild -> GuildMember -> PermissionFlag -> Bool +hasGuildMemberPermission g gm p = go (memberRoles gm) + where + go [] = False + go (x : xs) = case roleIdToRole g x of + Nothing -> go xs + Just a -> p `hasRolePermission` rolePerms a || go xs diff --git a/deps/discord-haskell/src/Discord/Internal/Types/ScheduledEvents.hs b/deps/discord-haskell/src/Discord/Internal/Types/ScheduledEvents.hs new file mode 100644 index 0000000..01f37a1 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/ScheduledEvents.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Structures pertaining to Discord Scheduled Events +module Discord.Internal.Types.ScheduledEvents where + +import Data.Aeson ( (.:) + , (.:!) + , (.:?) + , (.=) + , FromJSON(parseJSON) + , ToJSON(toJSON) + , Value(Null, Number, String) + , object + , withObject + , withText + ) +import Data.Aeson.Types ( Parser ) +import qualified Data.ByteString as B +import Data.Data ( Data ) +import Data.Default ( Default(def) ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time ( UTCTime ) +import Discord.Internal.Types.Prelude ( ChannelId + , GuildId + , InternalDiscordEnum + ( discordTypeParseJSON + , discordTypeStartValue + , fromDiscordType + ) + , ScheduledEventEntityId + , ScheduledEventId + , UserId + , (.==) + , (.=?) + , objectFromMaybes + ) +import Discord.Internal.Types.User ( GuildMember + , User + ) + + + +-- | The ScheduledEvent data structure +data ScheduledEvent + = ScheduledEventStage + { scheduledEventStageId :: ScheduledEventId + , scheduledEventStageGuildId :: GuildId + , scheduledEventStageChannelId :: ChannelId + , scheduledEventStageCreatorId :: Maybe UserId + , scheduledEventStageName :: T.Text + , scheduledEventStageDescription :: Maybe T.Text + , scheduledEventStageStartTime :: UTCTime + , scheduledEventStageEndTime :: Maybe UTCTime + , scheduledEventStagePrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventStageStatus :: ScheduledEventStatus + , scheduledEventStageEntityId :: Maybe ScheduledEventEntityId + , scheduledEventStageCreator :: Maybe User + , scheduledEventStageUserCount :: Maybe Integer + , scheduledEventStageImage :: Maybe ScheduledEventImageHash + } + | ScheduledEventVoice + { scheduledEventVoiceId :: ScheduledEventId + , scheduledEventVoiceGuildId :: GuildId + , scheduledEventVoiceChannelId :: ChannelId + , scheduledEventVoiceCreatorId :: Maybe UserId + , scheduledEventVoiceName :: T.Text + , scheduledEventVoiceDescription :: Maybe T.Text + , scheduledEventVoiceStartTime :: UTCTime + , scheduledEventVoiceEndTime :: Maybe UTCTime + , scheduledEventVoicePrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventVoiceStatus :: ScheduledEventStatus + , scheduledEventVoiceEntityId :: Maybe ScheduledEventEntityId + , scheduledEventVoiceCreator :: Maybe User + , scheduledEventVoiceUserCount :: Maybe Integer + , scheduledEventVoiceImage :: Maybe ScheduledEventImageHash + } + | ScheduledEventExternal + { scheduledEventExternalId :: ScheduledEventId + , scheduledEventExternalGuildId :: GuildId + , scheduledEventExternalLocation :: T.Text + , scheduledEventExternalCreatorId :: Maybe UserId + , scheduledEventExternalName :: T.Text + , scheduledEventExternalDescription :: Maybe T.Text + , scheduledEventExternalStartTime :: UTCTime + , scheduledEventExternalEndTime :: UTCTime + , scheduledEventExternalPrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventExternalStatus :: ScheduledEventStatus + , scheduledEventExternalEntityId :: Maybe ScheduledEventEntityId + , scheduledEventExternalCreator :: Maybe User + , scheduledEventExternalUserCount :: Maybe Integer + , scheduledEventExternalImage :: Maybe ScheduledEventImageHash + } + deriving (Show, Eq, Read) + +instance ToJSON ScheduledEvent where + toJSON ScheduledEventStage {..} = objectFromMaybes + [ "id" .== scheduledEventStageId + , "guild_id" .== scheduledEventStageGuildId + , "channel_id" .== scheduledEventStageChannelId + , "creator_id" .=? scheduledEventStageCreatorId + , "name" .== scheduledEventStageName + , "description" .=? scheduledEventStageDescription + , "scheduled_start_time" .== scheduledEventStageStartTime + , "scheduled_end_time" .=? scheduledEventStageEndTime + , "privacy_level" .== scheduledEventStagePrivacyLevel + , "entity_type" .== Number 1 + , "entity_id" .=? scheduledEventStageEntityId + , "creator" .=? scheduledEventStageCreator + , "user_count" .=? scheduledEventStageUserCount + , "image" .=? scheduledEventStageImage + ] + toJSON ScheduledEventVoice {..} = objectFromMaybes + [ "id" .== scheduledEventVoiceId + , "guild_id" .== scheduledEventVoiceGuildId + , "channel_id" .== scheduledEventVoiceChannelId + , "creator_id" .=? scheduledEventVoiceCreatorId + , "name" .== scheduledEventVoiceName + , "description" .=? scheduledEventVoiceDescription + , "scheduled_start_time" .== scheduledEventVoiceStartTime + , "scheduled_end_time" .=? scheduledEventVoiceEndTime + , "privacy_level" .== scheduledEventVoicePrivacyLevel + , "entity_type" .== Number 2 + , "entity_id" .=? scheduledEventVoiceEntityId + , "creator" .=? scheduledEventVoiceCreator + , "user_count" .=? scheduledEventVoiceUserCount + , "image" .=? scheduledEventVoiceImage + ] + toJSON ScheduledEventExternal {..} = objectFromMaybes + [ "id" .== scheduledEventExternalId + , "guild_id" .== scheduledEventExternalGuildId + , "creator_id" .=? scheduledEventExternalCreatorId + , "name" .== scheduledEventExternalName + , "description" .=? scheduledEventExternalDescription + , "scheduled_start_time" .== scheduledEventExternalStartTime + , "scheduled_end_time" .== scheduledEventExternalEndTime + , "privacy_level" .== scheduledEventExternalPrivacyLevel + , "entity_type" .== Number 3 + , "entity_id" .=? scheduledEventExternalEntityId + , "creator" .=? scheduledEventExternalCreator + , "user_count" .=? scheduledEventExternalUserCount + , "image" .=? scheduledEventExternalImage + , "entity_metadata" + .== object ["location" .= toJSON scheduledEventExternalLocation] + ] + + +instance FromJSON ScheduledEvent where + parseJSON = withObject + "ScheduledEvent" + (\v -> do + setype <- v .: "entity_type" :: Parser Int + seid <- v .: "id" + segid <- v .: "guild_id" + secrid <- v .:? "creator_id" + sename <- v .: "name" + sedesc <- v .:? "description" + sest <- v .: "scheduled_start_time" + sepl <- v .: "privacy_level" :: Parser ScheduledEventPrivacyLevel + sestat <- v .: "status" :: Parser ScheduledEventStatus + seeid <- v .:? "entity_id" + secrea <- v .:? "creator" + seuc <- v .:? "user_count" + seim <- v .:? "image" + + case setype of + 1 -> do + sechid <- v .: "channelId" + seet <- v .:? "scheduled_end_time" + return $ ScheduledEventStage seid + segid + sechid + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + 2 -> do + sechid <- v .: "channelId" + seet <- v .:? "scheduled_end_time" + return $ ScheduledEventVoice seid + segid + sechid + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + 3 -> do + semeta <- v .: "entity_metadata" + seloc <- withObject "entity_metadata" (.: "location") semeta + seet <- v .: "scheduled_end_time" + return $ ScheduledEventExternal seid + segid + seloc + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + _ -> error "unreachable" + ) + +-- | The privacy level of a scheduled event +data ScheduledEventPrivacyLevel = ScheduledEventPrivacyLevelGuildOnly + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ScheduledEventPrivacyLevel where + discordTypeStartValue = ScheduledEventPrivacyLevelGuildOnly + fromDiscordType ScheduledEventPrivacyLevelGuildOnly = 2 + +instance ToJSON ScheduledEventPrivacyLevel where + toJSON = toJSON . fromDiscordType + +instance FromJSON ScheduledEventPrivacyLevel where + parseJSON = discordTypeParseJSON "ScheduledEventPrivacyLevel" + +-- | The Status of a Scheduled Event +data ScheduledEventStatus + = ScheduledEventStatusScheduled + | ScheduledEventStatusActive + | ScheduledEventStatusCompleted + | ScheduledEventStatusCancelled + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ScheduledEventStatus where + discordTypeStartValue = ScheduledEventStatusScheduled + fromDiscordType ScheduledEventStatusScheduled = 1 + fromDiscordType ScheduledEventStatusActive = 2 + fromDiscordType ScheduledEventStatusCompleted = 3 + fromDiscordType ScheduledEventStatusCancelled = 4 + +instance ToJSON ScheduledEventStatus where + toJSON = toJSON . fromDiscordType + +instance FromJSON ScheduledEventStatus where + parseJSON = discordTypeParseJSON "ScheduledEventStatus" + +-- | The hash of the cover image of a ScheduledEvent +type ScheduledEventImageHash = T.Text + +-- | The type of images that can be uploaded +data CreateScheduledEventImageUploadType + = CreateScheduledEventImageUploadTypeJPG + | CreateScheduledEventImageUploadTypePNG + | CreateScheduledEventImageUploadTypeGIF + deriving (Show, Read, Eq, Ord) + +-- | The required information to add a cover image to a Scheduled Event +data CreateScheduledEventImage + = CreateScheduledEventImageURL T.Text + | CreateScheduledEventImageUpload CreateScheduledEventImageUploadType B.ByteString + deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateScheduledEventImage where + toJSON (CreateScheduledEventImageURL u) = String u + toJSON (CreateScheduledEventImageUpload typ bs) = + String + $ "data:" + <> (case typ of + CreateScheduledEventImageUploadTypeJPG -> "image/jpeg" + CreateScheduledEventImageUploadTypePNG -> "image/png" + CreateScheduledEventImageUploadTypeGIF -> "image/gif" + ) + <> ";base64," + <> T.decodeUtf8 bs + +instance FromJSON CreateScheduledEventImage where + parseJSON = + withText "CreateScheduledEventImage" (return . CreateScheduledEventImageURL) + +-- | Data required to create a Scheduled Event +data CreateScheduledEventData + = CreateScheduledEventDataStage + { createScheduleEventDataStageChannelId :: ChannelId + , createScheduleEventDataStageName :: T.Text + , createScheduleEventDataStagePrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataStageStartTime :: UTCTime + , createScheduleEventDataStageEndTime :: Maybe UTCTime + , createScheduleEventDataStageDescription :: Maybe T.Text + , createScheduleEventDataStageImage :: Maybe CreateScheduledEventImage + } + | CreateScheduledEventDataVoice + { createScheduleEventDataVoiceChannelId :: ChannelId + , createScheduleEventDataVoiceName :: T.Text + , createScheduleEventDataVoicePrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataVoiceStartTime :: UTCTime + , createScheduleEventDataVoiceEndTime :: Maybe UTCTime + , createScheduleEventDataVoiceDescription :: Maybe T.Text + , createScheduleEventDataVoiceImage :: Maybe CreateScheduledEventImage + } + | CreateScheduledEventDataExternal + { createScheduleEventDataExternalLocation :: T.Text + , createScheduleEventDataExternalName :: T.Text + , createScheduleEventDataExternalPrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataExternalStartTime :: UTCTime + , createScheduleEventDataExternalEndTime :: UTCTime + , createScheduleEventDataExternalDescription :: Maybe T.Text + , createScheduleEventDataExternalImage :: Maybe CreateScheduledEventImage + } + +instance ToJSON CreateScheduledEventData where + toJSON CreateScheduledEventDataStage {..} = objectFromMaybes + [ "channel_id" .== createScheduleEventDataStageChannelId + , "name" .== createScheduleEventDataStageName + , "privacy_level" .== createScheduleEventDataStagePrivacyLevel + , "scheduled_start_time" .== createScheduleEventDataStageStartTime + , "scheduled_end_time" .=? createScheduleEventDataStageEndTime + , "description" .=? createScheduleEventDataStageDescription + , "entity_type" .== Number 1 + , "image" .=? createScheduleEventDataStageImage + ] + toJSON CreateScheduledEventDataVoice {..} = objectFromMaybes + [ "channel_id" .== createScheduleEventDataVoiceChannelId + , "name" .== createScheduleEventDataVoiceName + , "privacy_level" .== createScheduleEventDataVoicePrivacyLevel + , "scheduled_start_time" .== createScheduleEventDataVoiceStartTime + , "scheduled_end_time" .=? createScheduleEventDataVoiceEndTime + , "description" .=? createScheduleEventDataVoiceDescription + , "entity_type" .== Number 2 + , "image" .=? createScheduleEventDataVoiceImage + ] + toJSON CreateScheduledEventDataExternal {..} = objectFromMaybes + [ "entity_metadata" + .== object ["location" .= createScheduleEventDataExternalLocation] + , "name" .== createScheduleEventDataExternalName + , "privacy_level" .== createScheduleEventDataExternalPrivacyLevel + , "scheduled_start_time" .== createScheduleEventDataExternalStartTime + , "scheduled_end_time" .== createScheduleEventDataExternalEndTime + , "description" .=? createScheduleEventDataExternalDescription + , "entity_type" .== Number 2 + , "image" .=? createScheduleEventDataExternalImage + ] + +instance FromJSON CreateScheduledEventData where + parseJSON = withObject + "CreateScheduledEventData" + (\v -> do + t <- v .: "entity_type" :: Parser Int + csename <- v .: "name" + csepl <- v .: "privacy_level" + csest <- v .: "scheduled_start_time" + csedesc <- v .:? "description" + cseimg <- v .:? "image" + + case t of + 1 -> do + csecid <- v .: "channel_id" + cseet <- v .:? "scheduled_end_time" + return $ CreateScheduledEventDataStage csecid + csename + csepl + csest + cseet + csedesc + cseimg + 2 -> do + csecid <- v .: "channel_id" + cseet <- v .:? "scheduled_end_time" + return $ CreateScheduledEventDataVoice csecid + csename + csepl + csest + cseet + csedesc + cseimg + 3 -> do + csemeta <- v .: "entity_metadata" + cseloc <- withObject "entity_metadata" (.: "location") csemeta + cseet <- v .: "scheduled_end_time" + return $ CreateScheduledEventDataVoice cseloc + csename + csepl + csest + cseet + csedesc + cseimg + _ -> error "unreachable" + ) + + +-- | The type of ScheduledEvent, used in 'ModifyScheduledEventData' +data ScheduledEventType + = ScheduledEventTypeStage + | ScheduledEventTypeVoice + | ScheduledEventTypeExternal + deriving (Show, Read, Ord, Eq, Data) + +instance InternalDiscordEnum ScheduledEventType where + discordTypeStartValue = ScheduledEventTypeStage + fromDiscordType ScheduledEventTypeStage = 1 + fromDiscordType ScheduledEventTypeVoice = 2 + fromDiscordType ScheduledEventTypeExternal = 3 + +instance FromJSON ScheduledEventType where + parseJSON = discordTypeParseJSON "ScheduledEventType" + +instance ToJSON ScheduledEventType where + toJSON = toJSON . fromDiscordType + +-- | Data required to issue a Modify Scheduled Event request +-- This isnt fully type-safe, and can allow for boggus requests but I don't +-- know of any sane solution to this +data ModifyScheduledEventData = ModifyScheduledEventData + { modifyScheduledEventDataChannelId :: Maybe (Maybe ChannelId) + , modifyScheduledEventDataLocation :: Maybe (Maybe T.Text) + , modifyScheduledEventDataName :: Maybe T.Text + , modifyScheduledEventDataPrivacyLevel :: Maybe ScheduledEventPrivacyLevel + , modifyScheduledEventDataStartTime :: Maybe UTCTime + , modifyScheduledEventDataEndTime :: Maybe UTCTime + , modifyScheduledEventDataDescription :: Maybe (Maybe T.Text) + , modifyScheduledEventDataType :: Maybe ScheduledEventType + , modifyScheduledEventDataStatus :: Maybe ScheduledEventStatus + , modifyScheduledEventDataImage :: Maybe CreateScheduledEventImage + } + +instance Default ModifyScheduledEventData where + def = ModifyScheduledEventData Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +instance ToJSON ModifyScheduledEventData where + toJSON ModifyScheduledEventData {..} = objectFromMaybes + [ "channel_id" .=? modifyScheduledEventDataChannelId + , "entity_metadata" .=? loc + , "name" .=? modifyScheduledEventDataName + , "scheduled_start_time" .=? modifyScheduledEventDataStartTime + , "scheduled_end_time" .=? modifyScheduledEventDataEndTime + , "description" .=? modifyScheduledEventDataDescription + , "entity_type" .=? modifyScheduledEventDataType + , "status" .=? modifyScheduledEventDataStatus + , "image" .=? modifyScheduledEventDataImage + ] + where + loc = case modifyScheduledEventDataLocation of + Nothing -> Nothing + Just Nothing -> Just Null + Just loc' -> Just $ object [("location", toJSON loc')] + +instance FromJSON ModifyScheduledEventData where + parseJSON = withObject + "ModifyScheduledEventData" + (\v -> do + -- The trivial fields + msename <- v .:? "name" + msest <- v .:? "scheduled_start_time" + mseet <- v .:? "scheduled_end_time" + msetype <- v .:? "entity_type" + msepl <- v .:? "privacy_level" + msestat <- v .:? "status" + mseimg <- v .:? "image" + + -- The not so trivial ones + msecid' <- v .:! "channel_id" + mseloc' <- v .:! "entity_metadata" + msedesc' <- v .:! "description" + + -- Extract the values + msecid <- case msecid' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- parseJSON x + return $ Just x' + + mseloc <- case mseloc' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- withObject "entity_metadata" (.: "location") x + return $ Just x' + + msedesc <- case msedesc' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- parseJSON x + return $ Just x' + + return $ ModifyScheduledEventData + { modifyScheduledEventDataChannelId = msecid + , modifyScheduledEventDataLocation = mseloc + , modifyScheduledEventDataName = msename + , modifyScheduledEventDataPrivacyLevel = msepl + , modifyScheduledEventDataStartTime = msest + , modifyScheduledEventDataEndTime = mseet + , modifyScheduledEventDataDescription = msedesc + , modifyScheduledEventDataType = msetype + , modifyScheduledEventDataStatus = msestat + , modifyScheduledEventDataImage = mseimg + } + ) + +-- | An User that subscribed to a Scheduled Event +data ScheduledEventUser = ScheduledEventUser + { scheduledEventUserEvent :: ScheduledEventId + , scheduledEventUserUser :: User + , scheduledEventUserGuildMember :: Maybe GuildMember + } + +instance FromJSON ScheduledEventUser where + parseJSON = withObject + "ScheduledEventUser" + (\v -> + ScheduledEventUser + <$> v .: "guild_scheduled_event_id" + <*> v .: "user" + <*> v .:? "member" + ) diff --git a/deps/discord-haskell/src/Discord/Internal/Types/User.hs b/deps/discord-haskell/src/Discord/Internal/Types/User.hs new file mode 100644 index 0000000..b23d2f1 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/User.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures pertaining to Discord User +module Discord.Internal.Types.User where + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as T +import Discord.Internal.Types.Prelude +import Data.Time (UTCTime) + +-- | Represents information about a user. +data User = User + { userId :: UserId -- ^ The user's id. + , userName :: T.Text -- ^ The user's username (not unique) + , userDiscrim :: Maybe T.Text -- ^ The user's 4-digit discord-tag. + , userGlobalName :: Maybe T.Text -- ^ The user's display name. + , userAvatar :: Maybe T.Text -- ^ The user's avatar hash. + , userIsBot :: Bool -- ^ User is an OAuth2 application. + , userIsWebhook :: Bool -- ^ User is a webhook. + , userIsSystem :: Maybe Bool -- ^ User is an official discord system user. + , userMfa :: Maybe Bool -- ^ User has two factor authentication enabled on the account. + , userBanner :: Maybe T.Text -- ^ User's banner hash + , userAccentColor :: Maybe Int -- ^ User's banner color + , userLocale :: Maybe T.Text -- ^ User's chosen language + , userVerified :: Maybe Bool -- ^ Whether the email has been verified. + , userEmail :: Maybe T.Text -- ^ The user's email. + , userFlags :: Maybe Integer -- ^ The user's flags. + , userPremiumType :: Maybe Integer -- ^ The user's premium type. + , userPublicFlags :: Maybe Integer -- ^ The user's public flags. + , userMember :: Maybe GuildMember -- ^ Some guild member info (message create/update) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON User where + parseJSON = withObject "User" $ \o -> + User <$> o .: "id" + <*> o .: "username" + <*> o .:? "discriminator" -- possibly not there in the case of webhooks + <*> o .:? "global_name" + <*> o .:? "avatar" + <*> o .:? "bot" .!= False + <*> pure False -- webhook + <*> o .:? "system" + <*> o .:? "mfa_enabled" + <*> o .:? "banner" + <*> o .:? "accent_color" + <*> o .:? "locale" + <*> o .:? "verified" + <*> o .:? "email" + <*> o .:? "flags" + <*> o .:? "premium_type" + <*> o .:? "public_flags" + <*> o .:? "member" + +instance ToJSON User where + toJSON User{..} = objectFromMaybes + [ "id" .== userId + , "username" .== userName + , "discriminator" .=? userDiscrim + , "global_name" .=? userGlobalName + , "avatar" .=? userAvatar + , "bot" .== userIsBot + , "system" .=? userIsSystem + , "mfa_enabled" .=? userMfa + , "banner" .=? userBanner + , "accent_color" .=? userAccentColor + , "verified" .=? userVerified + , "email" .=? userEmail + , "flags" .=? userFlags + , "premium_type" .=? userPremiumType + , "public_flags" .=? userPublicFlags + , "member" .=? userPublicFlags + ] + +-- TODO: fully update webhook structure +data Webhook = Webhook + { webhookId :: WebhookId + , webhookToken :: Maybe WebhookToken + , webhookChannelId :: ChannelId + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Webhook where + parseJSON = withObject "Webhook" $ \o -> + Webhook <$> o .: "id" + <*> o .:? "token" + <*> o .: "channel_id" + +-- | The connection object that the user has attached. +data ConnectionObject = ConnectionObject + { 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 + parseJSON = withObject "ConnectionObject" $ \o -> do + integrations <- o .: "integrations" + ConnectionObject <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "revoked" + <*> mapM (.: "id") integrations + <*> o .: "verified" + <*> o .: "friend_sync" + <*> o .: "show_activity" + <*> ( (==) (1::Int) <$> o .: "visibility") + + +-- | Representation of a guild member. +data GuildMember = GuildMember + { memberUser :: Maybe User -- ^ User object - not included in message_create or update + , memberNick :: Maybe T.Text -- ^ User's guild nickname + , memberAvatar :: Maybe T.Text -- ^ User's guild avatar hash + , memberRoles :: [RoleId] -- ^ Array of role ids + , memberJoinedAt :: UTCTime -- ^ When the user joined the guild + , memberPremiumSince :: Maybe UTCTime -- ^ When the user started boosting the guild + , memberDeaf :: Bool -- ^ Whether the user is deafened + , memberMute :: Bool -- ^ Whether the user is muted + , memberPending :: Bool -- ^ Whether the user has passed the guild's membership screening + , memberPermissions :: Maybe T.Text -- ^ total permissions of the member + , memberTimeoutEnd :: Maybe UTCTime -- ^ when the user's timeout will expire and they can communicate again + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildMember where + parseJSON = withObject "GuildMember" $ \o -> + GuildMember <$> o .:? "user" + <*> o .:? "nick" + <*> o .:? "avatar" + <*> o .: "roles" + <*> o .: "joined_at" + <*> o .:? "premium_since" + <*> o .: "deaf" + <*> o .: "mute" + <*> o .:? "pending" .!= False + <*> o .:? "permissions" + <*> o .:? "communication_disabled_until" + +instance ToJSON GuildMember where + toJSON GuildMember {..} = objectFromMaybes + [ "user" .=? memberUser + , "nick" .=? memberNick + , "avatar" .=? memberAvatar + , "roles" .== memberRoles + , "joined_at" .== memberJoinedAt + , "premium_since" .=? memberPremiumSince + , "deaf" .== memberDeaf + , "mute" .== memberMute + , "pending" .== memberPending + , "permissions" .=? memberPermissions + , "communication_disabled_until" .=? memberTimeoutEnd + ] diff --git a/deps/discord-haskell/src/Discord/Requests.hs b/deps/discord-haskell/src/Discord/Requests.hs new file mode 100644 index 0000000..6f2127e --- /dev/null +++ b/deps/discord-haskell/src/Discord/Requests.hs @@ -0,0 +1,23 @@ +module Discord.Requests + ( module Discord.Internal.Rest.Channel + , module Discord.Internal.Rest.Emoji + , module Discord.Internal.Rest.Guild + , module Discord.Internal.Rest.Invite + , module Discord.Internal.Rest.User + , module Discord.Internal.Rest.Voice + , module Discord.Internal.Rest.Webhook + , module Discord.Internal.Rest.ApplicationCommands + , module Discord.Internal.Rest.Interactions + , module Discord.Internal.Rest.ScheduledEvents + ) where + +import Discord.Internal.Rest.Channel +import Discord.Internal.Rest.Emoji +import Discord.Internal.Rest.Guild +import Discord.Internal.Rest.Invite +import Discord.Internal.Rest.User +import Discord.Internal.Rest.Voice +import Discord.Internal.Rest.Webhook +import Discord.Internal.Rest.ApplicationCommands +import Discord.Internal.Rest.Interactions +import Discord.Internal.Rest.ScheduledEvents diff --git a/deps/discord-haskell/src/Discord/Types.hs b/deps/discord-haskell/src/Discord/Types.hs new file mode 100644 index 0000000..d14027a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Types.hs @@ -0,0 +1,16 @@ +-- | Re-export user-visible types +module Discord.Types + ( module Discord.Internal.Types + ) where + +import Discord.Internal.Types hiding + ( GatewaySendableInternal(..) + , GatewayReceivable(..) + , EventInternalParse(..) + , InternalDiscordEnum(..) + , Base64Image(..) + + , colorToInternal + , convertToRGB + , hexToRGB + ) diff --git a/deps/discord-haskell/stack.yaml b/deps/discord-haskell/stack.yaml new file mode 100644 index 0000000..e1950a4 --- /dev/null +++ b/deps/discord-haskell/stack.yaml @@ -0,0 +1,12 @@ +extra-package-dbs: [] +packages: +- '.' + +resolver: lts-18.28 + +extra-deps: +- emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273 + + +nix: + packages: [ zlib, gmp ] diff --git a/deps/irc-client/.github/dependabot.yml b/deps/irc-client/.github/dependabot.yml new file mode 100644 index 0000000..da0b496 --- /dev/null +++ b/deps/irc-client/.github/dependabot.yml @@ -0,0 +1,7 @@ +version: 2 +updates: + - package-ecosystem: github-actions + directory: / + schedule: + interval: daily + diff --git a/deps/irc-client/.github/workflows/ci.yaml b/deps/irc-client/.github/workflows/ci.yaml new file mode 100644 index 0000000..9034267 --- /dev/null +++ b/deps/irc-client/.github/workflows/ci.yaml @@ -0,0 +1,31 @@ +name: Run tests + +on: pull_request + +jobs: + lint: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2.4.3 + with: + enable-stack: true + - name: Setup + run: | + stack --no-terminal install stylish-haskell hlint + - name: Lint + run: | + set -ex + stack --no-terminal exec -- hlint --no-summary . + stack --no-terminal exec -- find . -name '*.hs' -exec stylish-haskell -i {} \; + git diff --exit-code + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2.4.3 + with: + enable-stack: true + - name: Build + run: | + stack --no-terminal build diff --git a/deps/irc-client/.gitignore b/deps/irc-client/.gitignore new file mode 100644 index 0000000..afaa85d --- /dev/null +++ b/deps/irc-client/.gitignore @@ -0,0 +1,4 @@ +.cabal-sandbox +cabal.sandbox.config +dist +.stack-work diff --git a/deps/irc-client/.stylish-haskell.yaml b/deps/irc-client/.stylish-haskell.yaml new file mode 100644 index 0000000..2d3ca44 --- /dev/null +++ b/deps/irc-client/.stylish-haskell.yaml @@ -0,0 +1,56 @@ +# stylish-haskell configuration file +# https://github.com/jaspervdj/stylish-haskell +########################## + +steps: + # Import cleanup + - imports: + # Align the import names and import list throughout the entire + # file. + align: global + + # Import list is aligned with end of import including 'as' and + # 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + list_align: after_alias + + # Put as many import specs on same line as possible. + long_list_align: inline + + # () is right after the module name: + # + # > import Vector.Instances () + empty_list_align: right_after + + # Align import list on lines after the import under the start of + # the module name. + list_padding: module_name + + # There is no space between classes and constructors and the + # list of it's members. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + separate_lists: false + + # Language pragmas + - language_pragmas: + # Vertical-spaced language pragmas, one per line. + style: vertical + + # Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + align: false + + # Remove redundant language pragmas. + remove_redundant: true + + # Remove trailing whitespace + - trailing_whitespace: {} + +# Maximum line length, used by some of the steps above. +columns: 80 + +# Convert newlines to LF ("\n"). +newline: lf diff --git a/deps/irc-client/LICENSE b/deps/irc-client/LICENSE new file mode 100644 index 0000000..61d9d0c --- /dev/null +++ b/deps/irc-client/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015, Michael Walker <mike@barrucadu.co.uk> + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/deps/irc-client/Network/IRC/Client.hs b/deps/irc-client/Network/IRC/Client.hs new file mode 100644 index 0000000..abae449 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Network.IRC.Client +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- A simple IRC client library. Typical usage will be of this form: +-- +-- > run :: ByteString -> Int -> Text -> IO () +-- > run host port nick = do +-- > let conn = plainConnection host port +-- > let cfg = defaultInstanceConfig nick & handlers %~ (yourCustomEventHandlers:) +-- > runClient conn cfg () +-- +-- You shouldn't really need to tweak anything other than the event +-- handlers, as everything has been designed to be as simple as +-- possible. +module Network.IRC.Client + ( -- * Configuration + + -- | The configuration is logically split into two parts: the + -- /connection/ configuration (the 'ConnectionConfig' type) and the + -- /instance/ configuration (the 'InstanceConfig' type). + -- + -- - Connection configuration details how to connect to the IRC + -- server, and cannot be modified after the client has started + -- (although it can be read). + -- + -- - Instance configuration is everything else: the client's + -- nick, and version, handlers for received messages, and so + -- on. It can be modified after the client has started. + + -- ** Connection configuration + + -- | The following values can be changed with the exported lenses: + -- + -- - 'username' (default: \"irc-client\"). The username sent to + -- the server in the \"USER\" command. + -- + -- - 'realname' (default: \"irc-client\"). The real name sent to + -- the server in the \"USER\" command. + -- + -- - 'password' (default: @Nothing@). If set, the password sent to the + -- server in the \"PASS\" command. + -- + -- - 'flood' (default: @1@). The minimum time between sending + -- messages, to avoid flooding. + -- + -- - 'timeout' (default: @300@). The amount of time to wait for a + -- message from the server before locally timing out. + -- + -- - 'onconnect' (default: 'defaultOnConnect'). The action to + -- perform after sending the \"USER\" and \"PASS\" commands. + -- + -- - 'ondisconnect' (default: 'defaultOnDisconnect'). The action + -- to perform after disconnecting from the server + -- + -- - 'logfunc' (default: 'noopLogger'). The function to log received + -- and sent messages. + + ConnectionConfig + , plainConnection + , TLSConfig(..) + , tlsConnection + + -- *** Logging + + -- | The logging functions are told whether the message came from + -- the server or the client, and are given the raw bytestring. + + , Origin(..) + , stdoutLogger + , fileLogger + , noopLogger + + -- ** Instance configuration + + -- | The following values can be changed with the exported lenses: + -- + -- - 'nick'. The nick that 'defaultOnConnect' sends to the + -- server. This is also modified during runtime by the + -- 'welcomeNick' and 'nickMangler' default event handlers. + -- + -- - 'channels' (default: @[]@). The channels that + -- 'joinOnWelcome' joins. This is also modified during runtime + -- by the 'joinHandler' default event handler. + -- + -- - 'version' (default: \"irc-client-$VERSION\"). The + -- version that 'ctcpVersionHandler' sends. + -- + -- - 'handlers' (default: 'defaultEventHandlers'). The list of + -- event handlers. + -- + -- - 'ignore' (default: @[]@). The ignore list, events from + -- matching nicks are not handled. + + , InstanceConfig + , defaultInstanceConfig + + -- * Writing IRC clients + + -- | With this library, IRC clients are mostly composed of event + -- handlers. Event handlers are monadic actions operating in the + -- 'IRC' monad. + + , IRC + , send + , sendBS + , disconnect + , reconnect + + -- ** From event handlers + + , module Network.IRC.Client.Events + + -- ** From the outside + + -- | The 'ConnectionConfig', 'InstanceConfig', and some other stuff + -- are combined in the 'IRCState' type. This can be used to interact + -- with a client from the outside, by providing a way to run @IRC s + -- a@ actions. + + , IRCState + , getIRCState + , runIRCAction + , ConnectionState(..) + , getConnectionState + + -- * Execution + , runClient + + -- | If an 'IRCState' is constructed with 'newIRCState' and a client + -- started with 'runClientWith', then 'runIRCAction' can be used to + -- interact with that client. + + , newIRCState + , runClientWith + + -- | If the client times out from the server, the 'Timeout' + -- exception will be thrown, killing it. + , Timeout(..) + + -- * Concurrency + + -- | A client can manage a collection of threads, which get thrown + -- the 'Disconnect' exception whenever the client disconnects for + -- any reason (including a call to 'reconnect'). These can be + -- created from event handlers to manage long-running tasks. + , U.fork + , Disconnect(..) + + -- * Lenses + , module Network.IRC.Client.Lens + + -- * Utilities + , module Network.IRC.Client.Utils + , C.rawMessage + , C.toByteString + ) where + +import Control.Concurrent.STM (newTVarIO) +import Control.Concurrent.STM.TBMChan (newTBMChanIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import qualified Data.Conduit.Network.TLS as TLS +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Version (showVersion) +import qualified Data.X509 as X +import qualified Data.X509.CertificateStore as X +import qualified Data.X509.Validation as X +import Network.Connection as TLS (TLSSettings(..)) +import qualified Network.IRC.Conduit as C +import qualified Network.TLS as TLS + +import Network.IRC.Client.Events +import Network.IRC.Client.Internal +import Network.IRC.Client.Lens +-- I think exporting 'fork' with 'Disconnect' gives better documentation. +import Network.IRC.Client.Utils hiding (fork) +import qualified Network.IRC.Client.Utils as U + +import qualified Paths_irc_client as Paths + + +------------------------------------------------------------------------------- +-- Configuration + +-- | Connect to a server without TLS. +plainConnection + :: ByteString + -- ^ The hostname + -> Int + -- ^ The port + -> ConnectionConfig s +plainConnection host port_ = + setupInternal (C.ircClient port_ host) defaultOnConnect defaultOnDisconnect noopLogger host port_ + +-- | How to connect to a server over TLS. +data TLSConfig + = WithDefaultConfig ByteString Int + -- ^ Use @<http://hackage.haskell.org/package/irc-conduit/docs/Network-IRC-Conduit.html#t:defaultTLSConfig Network.IRC.Conduit.defaultTLSConfig>@. + | WithClientConfig TLS.TLSClientConfig + -- ^ Use the given configuration. The hostname and port are stored + -- as fields of the 'TLS.TLSClientConfig'. + | WithVerifier ByteString Int (X.CertificateStore -> TLS.ValidationCache -> X.ServiceID -> X.CertificateChain -> IO [X.FailedReason]) + -- ^ Use @<http://hackage.haskell.org/package/irc-conduit/docs/Network-IRC-Conduit.html#t:defaultTLSConfig Network.IRC.Conduit.defaultTLSConfig>@, + -- with the given certificate verifier. The certificate verifier is + -- a function which returns a list of reasons to reject the + -- certificate. + +-- | Connect to a server with TLS. +tlsConnection + :: TLSConfig + -- ^ How to initiate the TLS connection + -> ConnectionConfig s +tlsConnection (WithDefaultConfig host port_) = + setupInternal (C.ircTLSClient port_ host) defaultOnConnect defaultOnDisconnect noopLogger host port_ +tlsConnection (WithClientConfig cfg) = + setupInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect noopLogger host port_ + where + host = TLS.tlsClientHost cfg + port_ = TLS.tlsClientPort cfg +tlsConnection (WithVerifier host port_ verifier) = + setupInternal (C.ircTLSClient' cfg) defaultOnConnect defaultOnDisconnect noopLogger host port_ + where + cfg = + let cfg0 = C.defaultTLSConfig port_ host + -- this is a partial pattern match, but because I'm the + -- author of irc-conduit I can do this. + TLS.TLSSettings cTLSSettings = TLS.tlsClientTLSSettings cfg0 + cHooks = TLS.clientHooks cTLSSettings + in cfg0 { TLS.tlsClientTLSSettings = TLS.TLSSettings cTLSSettings + { TLS.clientHooks = cHooks + { TLS.onServerCertificate = verifier } + } + } + +-- | Construct a default IRC configuration from a nick +defaultInstanceConfig + :: Text + -- ^ The nick + -> InstanceConfig s +defaultInstanceConfig n = InstanceConfig + { _nick = n + , _channels = [] + , _version = T.append "irc-client-" (T.pack $ showVersion Paths.version) + , _handlers = defaultEventHandlers + , _ignore = [] + } + + +------------------------------------------------------------------------------- +-- Execution + +-- | Connect to the IRC server and run the client: receiving messages +-- and handing them off to handlers as appropriate. +runClient :: MonadIO m + => ConnectionConfig s + -> InstanceConfig s + -> s + -- ^ The initial value for the user state. + -> m () +runClient cconf iconf ustate = newIRCState cconf iconf ustate >>= runClientWith + +-- | Like 'runClient', but use the provided initial +-- 'IRCState'. +-- +-- Multiple clients should not be run with the same 'IRCState'. The +-- utility of this is to be able to run @IRC s a@ actions in order to +-- interact with the client from the outside. +runClientWith :: MonadIO m => IRCState s -> m () +runClientWith = runIRCAction runner + + +------------------------------------------------------------------------------- +-- State + +-- | Construct a new IRC state +newIRCState :: MonadIO m + => ConnectionConfig s + -> InstanceConfig s + -> s + -- ^ The initial value for the user state. + -> m (IRCState s) +newIRCState cconf iconf ustate = liftIO $ IRCState cconf + <$> newTVarIO ustate + <*> newTVarIO iconf + <*> (newTVarIO =<< newTBMChanIO 16) + <*> newTVarIO Disconnected + <*> newTVarIO S.empty diff --git a/deps/irc-client/Network/IRC/Client/Events.hs b/deps/irc-client/Network/IRC/Client/Events.hs new file mode 100644 index 0000000..eb922a8 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client/Events.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Client.Events +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : CPP, OverloadedStrings, RankNTypes +-- +-- Events and event handlers. When a message is received from the +-- server, all matching handlers are executed sequentially in the +-- order that they appear in the 'handlers' list. +module Network.IRC.Client.Events + ( -- * Handlers + EventHandler(..) + , matchCTCP + , matchNumeric + , matchType + , matchWhen + + -- * Default handlers + , defaultEventHandlers + , defaultOnConnect + , defaultOnDisconnect + + -- ** Individual handlers + , pingHandler + , kickHandler + , ctcpPingHandler + , ctcpVersionHandler + , ctcpTimeHandler + , welcomeNick + , joinOnWelcome + , joinHandler + , nickMangler + + -- * Re-exported + , Event(..) + , Message(..) + , Source(..) + , module Network.IRC.Conduit.Lens + ) where + +import Control.Applicative ((<$>), (<|>)) +import Control.Concurrent.STM (atomically, modifyTVar, readTVar) +import Control.Monad.Catch (SomeException, fromException, + throwM) +import Control.Monad.IO.Class (liftIO) +import Data.Char (isAlphaNum) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text, breakOn, takeEnd, toUpper) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime) +import Network.IRC.Conduit (Event(..), Message(..), + Source(..)) +import Network.IRC.Conduit.Lens +import Network.IRC.CTCP (fromCTCP) + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif + +import qualified Data.Text as T + +import Network.IRC.Client.Internal +import Network.IRC.Client.Lens +import Network.IRC.Client.Utils + + +------------------------------------------------------------------------------- +-- Handlers + +-- | Match the verb of a CTCP, ignoring case, and returning the arguments. +-- +-- > matchCTCP "ping" ":foo PRIVMSG #bar :\001PING\001" ==> Just [] +-- > matchCTCP "PING" ":foo PRIVMSG #bar :\001PING\001" ==> Just [] +-- > matchCTCP "ACTION" ":foo PRIVMSG #bar :\001ACTION dances\001" ==> Just ["dances"] +matchCTCP :: Text -> Event Text -> Maybe [Text] +matchCTCP verb ev = case _message ev of + Privmsg _ (Left ctcpbs) -> + let (v, args) = fromCTCP ctcpbs + in if toUpper verb == toUpper v + then Just args + else Nothing + _ -> Nothing + +-- | Match a numeric server message. Numeric messages are sent in +-- response to most things, such as connecting to the server, or +-- joining a channel. +-- +-- Numerics in the range 001 to 099 are informative messages, numerics +-- in the range 200 to 399 are responses to commands. Some common +-- numerics are: +-- +-- - 001 (RPL_WELCOME), sent after successfully connecting. +-- +-- - 331 (RPL_NOTOPIC), sent after joining a channel if it has no +-- topic. +-- +-- - 332 (RPL_TOPIC), sent after joining a channel if it has a +-- topic. +-- +-- - 432 (ERR_ERRONEUSNICKNAME), sent after trying to change to an +-- invalid nick. +-- +-- - 433 (ERR_NICKNAMEINUSE), sent after trying to change to a nick +-- already in use. +-- +-- - 436 (ERR_NICKCOLLISION), sent after trying to change to a nick +-- in use on another server. +-- +-- See Section 5 of @<https://tools.ietf.org/html/rfc2812#section-5 +-- RFC 2812>@ for a complete list. +-- +-- > matchNumeric 001 "001 :Welcome to irc.example.com" ==> True +-- > matchNumeric 332 "332 :#haskell: We like Haskell" ==> True +matchNumeric :: Int -> Event a -> Maybe [a] +matchNumeric num ev = case _message ev of + Numeric n args | num == n -> Just args + _ -> Nothing + +-- | Match events of the given type. Refer to +-- "Network.IRC.Conduit.Lens#Message" for the list of 'Prism''s. +-- +-- > matchType _Privmsg ":foo PRIVMSG #bar :hello world" ==> Just ("#bar", Right "hello world") +-- > matchType _Quit ":foo QUIT :goodbye world" ==> Just (Just "goodbye world") +matchType :: Prism' (Message a) b -> Event a -> Maybe b +matchType k = preview k . _message + +-- | Match a predicate against an event. +-- +-- > matchWhen (const True) ":foo PRIVMSG #bar :hello world" ==> Just ":foo PRIVMSG :hello world" +matchWhen :: (Event a -> Bool) -> Event a -> Maybe (Message a) +matchWhen p ev | p ev = Just (_message ev) +matchWhen _ _ = Nothing + + +------------------------------------------------------------------------------- +-- Default handlers + +-- | The default event handlers, the following are included: +-- +-- - respond to server @PING@ messages with a @PONG@; +-- - respond to CTCP @PING@ requests; +-- - respond to CTCP @VERSION@ requests with the version string; +-- - respond to CTCP @TIME@ requests with the system time; +-- - update the nick upon receiving the welcome message, in case the +-- server modifies it; +-- - mangle the nick if the server reports a collision; +-- - update the channel list on @JOIN@ and @KICK@. +defaultEventHandlers :: [EventHandler s] +defaultEventHandlers = + [ pingHandler + , kickHandler + , ctcpPingHandler + , ctcpTimeHandler + , ctcpVersionHandler + , welcomeNick + , joinOnWelcome + , joinHandler + , nickMangler + ] + +-- | The default connect handler: set the nick. +defaultOnConnect :: IRC s () +defaultOnConnect = do + iconf <- snapshot instanceConfig =<< getIRCState + send . Nick $ get nick iconf + +-- | The default disconnect handler +-- +-- - If the client disconnected due to a 'Timeout' exception, reconnect. +-- +-- - If the client disconnected due to another exception, rethrow it. +-- +-- - If the client disconnected without an exception, halt. +defaultOnDisconnect :: Maybe SomeException -> IRC s () +defaultOnDisconnect (Just exc) = case fromException exc of + Just Timeout -> reconnect + Nothing -> throwM exc +defaultOnDisconnect Nothing = pure () + + +------------------------------------------------------------------------------- +-- Individual handlers + +-- | Respond to server @PING@ messages with a @PONG@. +pingHandler :: EventHandler s +pingHandler = EventHandler (matchType _Ping) $ \_ (s1, s2) -> + send . Pong $ fromMaybe s1 s2 + +-- | Respond to CTCP @PING@ requests. +ctcpPingHandler :: EventHandler s +ctcpPingHandler = EventHandler (matchCTCP "PING") $ \src args -> case src of + User n -> send $ ctcpReply n "PING" args + _ -> pure () + +-- | Respond to CTCP @VERSION@ requests with the version string. +ctcpVersionHandler :: EventHandler s +ctcpVersionHandler = EventHandler (matchCTCP "VERSION") $ \src _ -> case src of + User n -> do + ver <- get version <$> (snapshot instanceConfig =<< getIRCState) + send $ ctcpReply n "VERSION" [ver] + _ -> pure () + +-- | Respond to CTCP @TIME@ requests with the system time. +ctcpTimeHandler :: EventHandler s +ctcpTimeHandler = EventHandler (matchCTCP "TIME") $ \src _ -> case src of + User n -> do + now <- liftIO getCurrentTime + send $ ctcpReply n "TIME" [T.pack $ formatTime defaultTimeLocale "%c" now] + _ -> pure () + +-- | Update the nick upon welcome (numeric reply 001), as it may not +-- be what we requested (eg, in the case of a nick too long). +welcomeNick :: EventHandler s +welcomeNick = EventHandler (matchNumeric 001) $ \_ args -> case args of + (srvNick:_) -> do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (set nick srvNick) + [] -> pure () + +-- | Join default channels upon welcome (numeric reply 001). If sent earlier, +-- the server might reject the JOIN attempts. +joinOnWelcome :: EventHandler s +joinOnWelcome = EventHandler (matchNumeric 001) $ \_ _ -> do + iconf <- snapshot instanceConfig =<< getIRCState + mapM_ (send . Join) $ get channels iconf + +-- | Mangle the nick if there's a collision (numeric replies 432, 433, +-- and 436) when we set it +nickMangler :: EventHandler s +nickMangler = EventHandler (\ev -> matcher 432 fresh ev <|> matcher 433 mangle ev <|> matcher 436 mangle ev) $ \_ -> uncurry go + where + matcher num f ev = case _message ev of + Numeric n args | num == n -> Just (f, args) + _ -> Nothing + + go f (_:srvNick:_) = do + theNick <- get nick <$> (snapshot instanceConfig =<< getIRCState) + + -- If the length of our nick and the server's idea of our nick + -- differ, it was truncated - so calculate the allowable length. + let nicklen = if T.length srvNick /= T.length theNick + then Just $ T.length srvNick + else Nothing + + setNick . trunc nicklen $ f srvNick + go _ _ = return () + + fresh n = if T.length n' == 0 then "f" else n' + where n' = T.filter isAlphaNum n + + mangle n = (n <> "1") `fromMaybe` charsubst n + + -- Truncate a nick, if there is a known length limit. + trunc len txt = maybe txt (`takeEnd` txt) len + + -- List of substring substitutions. It's important that these + -- don't contain any loops! + charsubst = transform [ ("i", "1") + , ("I", "1") + , ("l", "1") + , ("L", "1") + , ("o", "0") + , ("O", "0") + , ("A", "4") + , ("0", "1") + , ("1", "2") + , ("2", "3") + , ("3", "4") + , ("4", "5") + , ("5", "6") + , ("6", "7") + , ("7", "8") + , ("8", "9") + , ("9", "-") + ] + + -- Attempt to transform some text by the substitutions. + transform ((from, to):trs) txt = case breakOn' from txt of + Just (before, after) -> Just $ before <> to <> after + _ -> transform trs txt + transform [] _ = Nothing + +-- | Upon joining a channel (numeric reply 331 or 332), add it to the +-- list (if not already present). +joinHandler :: EventHandler s +joinHandler = EventHandler (\ev -> matchNumeric 331 ev <|> matchNumeric 332 ev) $ \_ args -> case args of + (c:_) -> do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI $ \iconf -> + (if c `elem` get channels iconf + then modify channels (c:) + else id) iconf + _ -> pure () + +-- | Update the channel list upon being kicked. +kickHandler :: EventHandler s +kickHandler = EventHandler (matchType _Kick) $ \src (n, _, _) -> do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ do + theNick <- get nick <$> readTVar tvarI + case src of + Channel c _ + | n == theNick -> delChan tvarI c + | otherwise -> pure () + _ -> pure () + + +------------------------------------------------------------------------------- +-- Utils + +-- | Break some text on the first occurrence of a substring, removing +-- the substring from the second portion. +breakOn' :: Text -> Text -> Maybe (Text, Text) +breakOn' delim txt = if T.length after >= T.length delim + then Just (before, T.drop (T.length delim) after) + else Nothing + where + (before, after) = breakOn delim txt diff --git a/deps/irc-client/Network/IRC/Client/Internal.hs b/deps/irc-client/Network/IRC/Client/Internal.hs new file mode 100644 index 0000000..24ea553 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client/Internal.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Network.IRC.Client.Internal +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : CPP, OverloadedStrings, ScopedTypeVariables +-- +-- Most of the hairy code. This isn't all internal, due to messy +-- dependencies, but I've tried to make this as \"internal\" as +-- reasonably possible. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal + ( module Network.IRC.Client.Internal + , module Network.IRC.Client.Internal.Lens + , module Network.IRC.Client.Internal.Types + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO, killThread, + myThreadId, threadDelay, + throwTo) +import Control.Concurrent.STM (STM, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan, + isClosedTBMChan, + isEmptyTBMChan, newTBMChan, + readTBMChan, writeTBMChan) +import Control.Monad (forM_, unless, void, when) +import Control.Monad.Catch (SomeException, catch) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ask, runReaderT) +import Data.ByteString (ByteString, isPrefixOf) +import Data.Conduit (ConduitM, await, + awaitForever, yield, (.|)) +import Data.IORef (IORef, newIORef, readIORef, + writeIORef) +import qualified Data.Set as S +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time.Clock (NominalDiffTime, UTCTime, + addUTCTime, diffUTCTime, + getCurrentTime) +import Data.Time.Format (formatTime) +import Data.Void (Void) +import Network.IRC.Conduit (Event(..), Message(..), + Source(..), floodProtector, + rawMessage, toByteString) + +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif + +import Network.IRC.Client.Internal.Lens +import Network.IRC.Client.Internal.Types +import Network.IRC.Client.Lens + + +------------------------------------------------------------------------------- +-- * Configuration + +-- | Config to connect to a server using the supplied connection +-- function. +setupInternal + :: (IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ()) + -- ^ Function to start the network conduits. + -> IRC s () + -- ^ Connect handler + -> (Maybe SomeException -> IRC s ()) + -- ^ Disconnect handler + -> (Origin -> ByteString -> IO ()) + -- ^ Logging function + -> ByteString + -- ^ Server hostname + -> Int + -- ^ Server port + -> ConnectionConfig s +setupInternal f oncon ondis logf host port_ = ConnectionConfig + { _func = f + , _username = "irc-client" + , _realname = "irc-client" + , _password = Nothing + , _server = host + , _port = port_ + , _flood = 1 + , _timeout = 300 + , _onconnect = oncon + , _ondisconnect = ondis + , _logfunc = logf + } + + +------------------------------------------------------------------------------- +-- * Event loop + +-- | The event loop. +runner :: IRC s () +runner = do + state <- getIRCState + let cconf = _connectionConfig state + + -- Set the real- and user-name + let theUser = get username cconf + let theReal = get realname cconf + let thePass = get password cconf + + -- Initialise the IRC session + let initialise = flip runIRCAction state $ do + liftIO . atomically $ writeTVar (_connectionState state) Connected + mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) thePass + sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal] + _onconnect cconf + + -- Run the event loop, and call the disconnect handler if the remote + -- end closes the socket. + antiflood <- liftIO $ floodProtector (_flood cconf) + + -- An IORef to keep track of the time of the last received message, to allow a local timeout. + lastReceived <- liftIO $ newIORef =<< getCurrentTime + + squeue <- liftIO . readTVarIO $ _sendqueue state + + let source = sourceTBMChan squeue + .| antiflood + .| logConduit (_logfunc cconf FromClient . toByteString . concealPass) + let sink = forgetful + .| logConduit (_logfunc cconf FromServer . _raw) + .| eventSink lastReceived state + + -- Fork a thread to disconnect if the timeout elapses. + mainTId <- liftIO myThreadId + let time = _timeout cconf + let delayms = 1000000 * round time + let timeoutThread = do + now <- getCurrentTime + prior <- readIORef lastReceived + if diffUTCTime now prior >= time + then throwTo mainTId Timeout + else threadDelay delayms >> timeoutThread + timeoutTId <- liftIO (forkIO timeoutThread) + + -- Start the client. + (exc :: Maybe SomeException) <- liftIO $ catch + (_func cconf initialise sink source >> killThread timeoutTId >> pure Nothing) + (pure . Just) + + disconnect + _ondisconnect cconf exc + +-- | Forget failed decodings. +forgetful :: Monad m => ConduitM (Either a b) b m () +forgetful = awaitForever go where + go (Left _) = return () + go (Right b) = yield b + +-- | Block on receiving a message and invoke all matching handlers. +eventSink :: MonadIO m => IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m () +eventSink lastReceived ircstate = go where + go = await >>= maybe (return ()) (\event -> do + -- Record the current time. + now <- liftIO getCurrentTime + liftIO $ writeIORef lastReceived now + + -- Handle the event. + let event' = decodeUtf8 <$> event + ignored <- isIgnored ircstate event' + unless ignored . liftIO $ do + iconf <- snapshot instanceConfig ircstate + forM_ (get handlers iconf) $ \(EventHandler matcher handler) -> + maybe (pure ()) + (void . flip runIRCAction ircstate . handler (_source event')) + (matcher event') + + -- If disconnected, do not loop. + disconnected <- liftIO . atomically $ (==Disconnected) <$> getConnectionState ircstate + unless disconnected go) + +-- | Check if an event is ignored or not. +isIgnored :: MonadIO m => IRCState s -> Event Text -> m Bool +isIgnored ircstate ev = do + iconf <- liftIO . readTVarIO . _instanceConfig $ ircstate + let ignoreList = _ignore iconf + + return $ + case _source ev of + User n -> (n, Nothing) `elem` ignoreList + Channel c n -> ((n, Nothing) `elem` ignoreList) || ((n, Just c) `elem` ignoreList) + Server _ -> False + +-- |A conduit which logs everything which goes through it. +logConduit :: MonadIO m => (a -> IO ()) -> ConduitM a a m () +logConduit logf = awaitForever $ \x -> do + -- Call the logging function + liftIO $ logf x + + -- And pass the message on + yield x + +-- | Print messages to stdout, with the current time. +stdoutLogger :: Origin -> ByteString -> IO () +stdoutLogger origin x = do + now <- getCurrentTime + + putStrLn $ unwords + [ formatTime defaultTimeLocale "%c" now + , if origin == FromServer then "<---" else "--->" + , init . tail $ show x + ] + +-- | Append messages to a file, with the current time. +fileLogger :: FilePath -> Origin -> ByteString -> IO () +fileLogger fp origin x = do + now <- getCurrentTime + + appendFile fp $ unwords + [ formatTime defaultTimeLocale "%c" now + , if origin == FromServer then "--->" else "<---" + , init . tail $ show x + , "\n" + ] + +-- | Do no logging. +noopLogger :: a -> b -> IO () +noopLogger _ _ = return () + +-- | Clear passwords from logs. +concealPass :: Message ByteString -> Message ByteString +concealPass (RawMsg msg) + | "PASS " `isPrefixOf` msg = rawMessage "PASS" ["<password redacted>"] +concealPass m = m + + +------------------------------------------------------------------------------- +-- * Messaging + +-- | Send a message as UTF-8, using TLS if enabled. This blocks if +-- messages are sent too rapidly. +send :: Message Text -> IRC s () +send = sendBS . fmap encodeUtf8 + +-- | Send a message, using TLS if enabled. This blocks if messages are +-- sent too rapidly. +sendBS :: Message ByteString -> IRC s () +sendBS msg = do + qv <- _sendqueue <$> getIRCState + liftIO . atomically $ flip writeTBMChan msg =<< readTVar qv + + +------------------------------------------------------------------------------- +-- * Disconnecting + +-- | Disconnect from the server, properly tearing down the TLS session +-- (if there is one). +disconnect :: IRC s () +disconnect = do + s <- getIRCState + + liftIO $ do + connState <- readTVarIO (_connectionState s) + case connState of + Connected -> do + -- Set the state to @Disconnecting@ + atomically $ writeTVar (_connectionState s) Disconnecting + + -- Wait for all messages to be sent, or a minute has passed. + timeoutBlock 60 . atomically $ do + queue <- readTVar (_sendqueue s) + (||) <$> isEmptyTBMChan queue <*> isClosedTBMChan queue + + -- Close the chan, which closes the sending conduit, and set + -- the state to @Disconnected@. + atomically $ do + closeTBMChan =<< readTVar (_sendqueue s) + writeTVar (_connectionState s) Disconnected + + -- Kill all managed threads. Don't wait for them to terminate + -- here, as they might be masking exceptions and not pick up + -- the 'Disconnect' for a while; just clear the list. + mapM_ (`throwTo` Disconnect) =<< readTVarIO (_runningThreads s) + atomically $ writeTVar (_runningThreads s) S.empty + + -- If already disconnected, or disconnecting, do nothing. + _ -> pure () + +-- | Disconnect from the server (this will wait for all messages to be +-- sent, or a minute to pass), and then connect again. +-- +-- This can be called after the client has already disconnected, in +-- which case it will just connect again. +-- +-- Like 'runClient' and 'runClientWith', this will not return until +-- the client terminates (ie, disconnects without reconnecting). +reconnect :: IRC s () +reconnect = do + disconnect + + -- create a new send queue + s <- getIRCState + liftIO . atomically $ + writeTVar (_sendqueue s) =<< newTBMChan 16 + + runner + + +------------------------------------------------------------------------------- +-- * Utils + +-- | Interact with a client from the outside, by using its 'IRCState'. +runIRCAction :: MonadIO m => IRC s a -> IRCState s -> m a +runIRCAction ma = liftIO . runReaderT (runIRC ma) + +-- | Access the client state. +getIRCState :: IRC s (IRCState s) +getIRCState = ask + +-- | Get the connection state from an IRC state. +getConnectionState :: IRCState s -> STM ConnectionState +getConnectionState = readTVar . _connectionState + +-- | Block until an action is successful or a timeout is reached. +timeoutBlock :: MonadIO m => NominalDiffTime -> IO Bool -> m () +timeoutBlock dt check = liftIO $ do + finish <- addUTCTime dt <$> getCurrentTime + let wait = do + now <- getCurrentTime + cond <- check + when (now < finish && not cond) wait + wait + +-- | A simple wrapper around a TBMChan. As data is pushed into the +-- channel, the source will read it and pass it down the conduit +-- pipeline. When the channel is closed, the source will close also. +-- +-- If the channel fills up, the pipeline will stall until values are +-- read. +-- +-- From stm-conduit-3.0.0 (by Clark Gaebel <cg.wowus.cg@gmail.com>) +sourceTBMChan :: MonadIO m => TBMChan a -> ConduitM () a m () +sourceTBMChan ch = loop where + loop = do + a <- liftIO . atomically $ readTBMChan ch + case a of + Just x -> yield x >> loop + Nothing -> pure () diff --git a/deps/irc-client/Network/IRC/Client/Internal/Lens.hs b/deps/irc-client/Network/IRC/Client/Internal/Lens.hs new file mode 100644 index 0000000..783aa63 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client/Internal/Lens.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Client.Internal.Lens +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : CPP, ImpredicativeTypes +-- +-- Types and functions for dealing with optics without depending on +-- the lens library. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal.Lens where + +import Control.Applicative (Const(..)) +import Control.Concurrent.STM (STM, TVar, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Functor.Contravariant (Contravariant) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid (First(..)) +import Data.Profunctor (Choice) + + +------------------------------------------------------------------------------- +-- * Internal lens synonyms + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getter Control.Lens.Getter.Getter>@. +type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Getter.html#t:Getting Control.Lens.Getter.Getting>@. +type Getting r s a = (a -> Const r a) -> s -> Const r s + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Prism'. +type Prism' s a = Prism s s a a + + +------------------------------------------------------------------------------- +-- * Utilities + +-- | Get a value from a lens. +{-# INLINE get #-} +get :: Getting a s a -> s -> a +get lens = getConst . lens Const + +-- | Set a value in a lens. +{-# INLINE set #-} +set :: Lens' s a -> a -> s -> s +set lens a = runIdentity . lens (\_ -> Identity a) + +-- | Modify a value in a lens. +{-# INLINE modify #-} +modify :: Lens' s a -> (a -> a) -> s -> s +modify lens f s = let a = get lens s in set lens (f a) s + +-- | Read a value from a prism. +{-# INLINE preview #-} +preview :: Prism' s a -> s -> Maybe a +preview lens = getFirst . getConst . lens (Const . First . Just) + + +------------------------------------------------------------------------------- +-- ** STM + +-- | Atomically snapshot some shared state. +snapshot :: MonadIO m => Getting (TVar a) s (TVar a) -> s -> m a +snapshot lens = liftIO . readTVarIO . get lens + +-- | Atomically snapshot and modify some shared state. +snapshotModify :: MonadIO m => Lens' s (TVar a) -> (a -> STM (a, b)) -> s -> m b +snapshotModify lens f s = liftIO . atomically $ do + let avar = get lens s + a <- readTVar avar + (a', b) <- f a + writeTVar avar a' + pure b diff --git a/deps/irc-client/Network/IRC/Client/Internal/Types.hs b/deps/irc-client/Network/IRC/Client/Internal/Types.hs new file mode 100644 index 0000000..73fbf14 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client/Internal/Types.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Network.IRC.Client.Internal.Types +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses +-- +-- Internal types. Most of these are re-exported elsewhere as lenses. +-- +-- This module is NOT considered to form part of the public interface +-- of this library. +module Network.IRC.Client.Internal.Types where + +import Control.Applicative (Alternative) +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM (TVar, atomically, readTVar, + readTVarIO, writeTVar) +import Control.Concurrent.STM.TBMChan (TBMChan) +import Control.Monad (MonadPlus) +import Control.Monad.Catch (Exception, MonadCatch, + MonadMask, MonadThrow, + SomeException) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, ReaderT, asks) +import Control.Monad.State (MonadState(..)) +import Data.ByteString (ByteString) +import Data.Conduit (ConduitM) +import qualified Data.Set as S +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime) +import Data.Void (Void) +import Network.IRC.Conduit (Event(..), Message, Source) + + +------------------------------------------------------------------------------- +-- * The IRC monad + +-- | The IRC monad. +newtype IRC s a = IRC { runIRC :: ReaderT (IRCState s) IO a } + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader (IRCState s), MonadThrow, MonadCatch, MonadMask) + +instance MonadState s (IRC s) where + state f = do + tvar <- asks _userState + liftIO . atomically $ do + (a, s) <- f <$> readTVar tvar + writeTVar tvar s + pure a + get = do + tvar <- asks _userState + liftIO $ readTVarIO tvar + put s = do + tvar <- asks _userState + liftIO $ atomically (writeTVar tvar s) + +------------------------------------------------------------------------------- +-- * State + +-- | The state of an IRC session. +data IRCState s = IRCState + { _connectionConfig :: ConnectionConfig s + -- ^ Read-only connection configuration + , _userState :: TVar s + -- ^ Mutable user state + , _instanceConfig :: TVar (InstanceConfig s) + -- ^ Mutable instance configuration in STM + , _sendqueue :: TVar (TBMChan (Message ByteString)) + -- ^ Message send queue. + , _connectionState :: TVar ConnectionState + -- ^ State of the connection. + , _runningThreads :: TVar (S.Set ThreadId) + -- ^ Threads which will be killed when the client disconnects. + } + +-- | The static state of an IRC server connection. +data ConnectionConfig s = ConnectionConfig + { _func :: IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO () + -- ^ Function to connect and start the conduits. + , _server :: ByteString + -- ^ The server host. + , _port :: Int + -- ^ The server port. + , _username :: Text + -- ^ Client username; sent to the server during the initial set-up. + , _realname :: Text + -- ^ Client realname; sent to the server during the initial set-up. + , _password :: Maybe Text + -- ^ Client password; sent to the server during the initial set-up. + , _flood :: NominalDiffTime + -- ^ The minimum time between two adjacent messages. + , _timeout :: NominalDiffTime + -- ^ The maximum time (in seconds) between received messages from + -- the server. If no messages arrive from the server for this + -- period, the client is sent a 'Timeout' exception and disconnects. + , _onconnect :: IRC s () + -- ^ Action to run after sending the @PASS@ and @USER@ commands to the + -- server. The default behaviour is to send the @NICK@ command. + , _ondisconnect :: Maybe SomeException -> IRC s () + -- ^ Action to run after disconnecting from the server, both by + -- local choice and by losing the connection. This is run after + -- tearing down the connection. If the connection terminated due to + -- an exception, it is given. The default behaviour is to reconnect + -- if a timeout, otherwise rethrow any exception. + , _logfunc :: Origin -> ByteString -> IO () + -- ^ Function to log messages sent to and received from the server. + } + +-- | The updateable state of an IRC connection. +data InstanceConfig s = InstanceConfig + { _nick :: Text + -- ^ Client nick + , _channels :: [Text] + -- ^ Current channels: this list both determines the channels to join on + -- connect, and is modified by the default event handlers when channels + -- are joined or parted. + , _version :: Text + -- ^ The version is sent in response to the CTCP \"VERSION\" request by + -- the default event handlers. + , _handlers :: [EventHandler s] + -- ^ The registered event handlers. The order in this list is the + -- order in which they are executed. + , _ignore :: [(Text, Maybe Text)] + -- ^ List of nicks (optionally restricted to channels) to ignore + -- messages from. 'Nothing' ignores globally. + } + +-- | The state of the connection. +data ConnectionState = Connected | Disconnecting | Disconnected + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | The origin of a message. +data Origin = FromServer | FromClient + deriving (Bounded, Enum, Eq, Ord, Read, Show) + + +------------------------------------------------------------------------------- +-- * Events + +-- | A function which handles an event. +data EventHandler s where + EventHandler + :: (Event Text -> Maybe b) + -> (Source Text -> b -> IRC s ()) + -> EventHandler s + + +------------------------------------------------------------------------------- +-- * Exceptions + +-- | Exception thrown to kill the client if the timeout elapses with +-- nothing received from the server. +data Timeout = Timeout + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Exception Timeout + +-- | Exception thrown to all managed threads when the client +-- disconnects. +data Disconnect = Disconnect + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Exception Disconnect diff --git a/deps/irc-client/Network/IRC/Client/Lens.hs b/deps/irc-client/Network/IRC/Client/Lens.hs new file mode 100644 index 0000000..0afc3f5 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client/Lens.hs @@ -0,0 +1,189 @@ +-- | +-- Module : Network.IRC.Client.Lens +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : CPP +-- +-- 'Lens'es and 'Prism's. +module Network.IRC.Client.Lens where + +import Control.Concurrent.STM (TVar) +import Control.Monad.Catch (SomeException) +import Data.ByteString (ByteString) +import Data.Profunctor (Choice(right'), + Profunctor(dimap)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) + +import Network.IRC.Client.Internal.Lens +import Network.IRC.Client.Internal.Types + +{-# ANN module ("HLint: ignore Redundant lambda") #-} + +-- CPP seem to dislike the first ' on the RHS… +-- This style of CPP usage doesn't work with clang, which means won't work on Mac. +{- +#define PRIME() ' + +#define LENS(S,F,A) \ + {-# INLINE F #-}; \ + {-| PRIME()Lens' for '_/**/F'. -}; \ + F :: Lens' S A; \ + F = \ afb s -> (\ b -> s {_/**/F = b}) <$> afb (_/**/F s) + +#define GETTER(S,F,A) \ + {-# INLINE F #-}; \ + {-| PRIME()Getter' for '_/**/F'. -}; \ + F :: Getter S A; \ + F = \ afb s -> (\ b -> s {_/**/F = b}) <$> afb (_/**/F s) + +#define PRISM(S,C,ARG,TUP,A) \ + {-| PRIME()Prism' for 'C'. -}; \ + {-# INLINE _/**/C #-}; \ + _/**/C :: Prism' S A; \ + _/**/C = dimap (\ s -> case s of C ARG -> Right TUP; _ -> Left s) \ + (either pure $ fmap (\ TUP -> C ARG)) . right' + +-} + +------------------------------------------------------------------------------- +-- * Lenses for 'IRCState' + +{-# INLINE connectionConfig #-} +{-| 'Getter' for '_connectionConfig'. -} +connectionConfig :: Getter (IRCState s) (ConnectionConfig s) +connectionConfig = \ afb s -> (\ b -> s {_connectionConfig = b}) <$> afb (_connectionConfig s) + +{-# INLINE userState #-} +{-| 'Lens' for '_userState'. -} +userState :: Lens' (IRCState s) (TVar s) +userState = \ afb s -> (\ b -> s {_userState = b}) <$> afb (_userState s) + +{-# INLINE instanceConfig #-} +{-| 'Lens' for '_instanceConfig'. -} +instanceConfig :: Lens' (IRCState s) (TVar (InstanceConfig s)) +instanceConfig = \ afb s -> (\ b -> s {_instanceConfig = b}) <$> afb (_instanceConfig s) + +{-# INLINE connectionState #-} +{-| 'Lens' for '_connectionState'. -} +connectionState :: Lens' (IRCState s) (TVar ConnectionState) +connectionState = \ afb s -> (\ b -> s {_connectionState = b}) <$> afb (_connectionState s) + +------------------------------------------------------------------------------- +-- * Lenses for 'ConnectionConfig' + +{-# INLINE server #-} +{-| 'Getter' for '_server'. -} +server :: Getter (ConnectionConfig s) ByteString +server = \ afb s -> (\ b -> s {_server = b}) <$> afb (_server s) + +{-# INLINE port #-} +{-| 'Getter' for '_port'. -} +port :: Getter (ConnectionConfig s) Int +port = \ afb s -> (\ b -> s {_port = b}) <$> afb (_port s) + +{-# INLINE username #-} +{-| 'Lens' for '_username'. -} +username :: Lens' (ConnectionConfig s) Text +username = \ afb s -> (\ b -> s {_username = b}) <$> afb (_username s) + +{-# INLINE realname #-} +{-| 'Lens' for '_realname'. -} +realname :: Lens' (ConnectionConfig s) Text +realname = \ afb s -> (\ b -> s {_realname = b}) <$> afb (_realname s) + +{-# INLINE password #-} +{-| 'Lens' for '_password'. -} +password :: Lens' (ConnectionConfig s) (Maybe Text) +password = \ afb s -> (\ b -> s {_password = b}) <$> afb (_password s) + +{-# INLINE flood #-} +{-| 'Lens' for '_flood'. -} +flood :: Lens' (ConnectionConfig s) NominalDiffTime +flood = \ afb s -> (\ b -> s {_flood = b}) <$> afb (_flood s) + +{-# INLINE timeout #-} +{-| 'Lens' for '_timeout'. -} +timeout :: Lens' (ConnectionConfig s) NominalDiffTime +timeout = \ afb s -> (\ b -> s {_timeout = b}) <$> afb (_timeout s) + +{-# INLINE onconnect #-} +{-| 'Lens' for '_onconnect'. -} +onconnect :: Lens' (ConnectionConfig s) (IRC s ()) +onconnect = \ afb s -> (\ b -> s {_onconnect = b}) <$> afb (_onconnect s) + +{-# INLINE ondisconnect #-} +{-| 'Lens' for '_ondisconnect'. -} +ondisconnect :: Lens' (ConnectionConfig s) (Maybe SomeException -> IRC s ()) +ondisconnect = \ afb s -> (\ b -> s {_ondisconnect = b}) <$> afb (_ondisconnect s) + +{-# INLINE logfunc #-} +{-| 'Lens' for '_logfunc'. -} +logfunc :: Lens' (ConnectionConfig s) (Origin -> ByteString -> IO ()) +logfunc = \ afb s -> (\ b -> s {_logfunc = b}) <$> afb (_logfunc s) + +------------------------------------------------------------------------------- +-- * Lenses for 'InstanceConfig' + +{-# INLINE nick #-} +{-| 'Lens' for '_nick'. -} +nick :: Lens' (InstanceConfig s) Text +nick = \ afb s -> (\ b -> s {_nick = b}) <$> afb (_nick s) + +{-# INLINE channels #-} +{-| 'Lens' for '_channels'. -} +channels :: Lens' (InstanceConfig s) [Text] +channels = \ afb s -> (\ b -> s {_channels = b}) <$> afb (_channels s) + +{-# INLINE version #-} +{-| 'Lens' for '_version'. -} +version :: Lens' (InstanceConfig s) Text +version = \ afb s -> (\ b -> s {_version = b}) <$> afb (_version s) + +{-# INLINE handlers #-} +{-| 'Lens' for '_version'. -} +handlers :: Lens' (InstanceConfig s) [EventHandler s] +handlers = \ afb s -> (\ b -> s {_handlers = b}) <$> afb (_handlers s) + +{-# INLINE ignore #-} +{-| 'Lens' for '_ignore'. -} +ignore :: Lens' (InstanceConfig s) [(Text, Maybe Text)] +ignore = \ afb s -> (\ b -> s {_ignore = b}) <$> afb (_ignore s) + +------------------------------------------------------------------------------- +-- * Prisms for 'ConnectionState' + +{-| 'Prism' for 'Connected'. -} +{-# INLINE _Connected #-} +_Connected :: Prism' ConnectionState () +_Connected = dimap (\ s -> case s of Connected -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> Connected)) . right' + +{-| 'Prism' for 'Disconnecting'. -} +{-# INLINE _Disconnecting #-} +_Disconnecting :: Prism' ConnectionState () +_Disconnecting = dimap (\ s -> case s of Disconnecting -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> Disconnecting)) . right' + +{-| 'Prism' for 'Disconnected'. -} +{-# INLINE _Disconnected #-} +_Disconnected :: Prism' ConnectionState () +_Disconnected = dimap (\ s -> case s of Disconnected -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> Disconnected)) . right' + +------------------------------------------------------------------------------- +-- * Prisms for 'Origin' + +{-| 'Prism' for 'FromServer'. -} +{-# INLINE _FromServer #-} +_FromServer :: Prism' Origin () +_FromServer = dimap (\ s -> case s of FromServer -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> FromServer)) . right' + +{-| 'Prism' for 'FromClient'. -} +{-# INLINE _FromClient #-} +_FromClient :: Prism' Origin () +_FromClient = dimap (\ s -> case s of FromClient -> Right (); _ -> Left s) + (either pure $ fmap (\ () -> FromClient)) . right' diff --git a/deps/irc-client/Network/IRC/Client/Utils.hs b/deps/irc-client/Network/IRC/Client/Utils.hs new file mode 100644 index 0000000..f9833c7 --- /dev/null +++ b/deps/irc-client/Network/IRC/Client/Utils.hs @@ -0,0 +1,156 @@ +-- | +-- Module : Network.IRC.Client.Utils +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : portable +-- +-- Commonly-used utility functions for IRC clients. +module Network.IRC.Client.Utils + ( -- * Nicks + setNick + + -- * Channels + , leaveChannel + , delChan + + -- * Events + , addHandler + , reply + , replyTo + + -- * CTCPs + , ctcp + , ctcpReply + + -- * Connection state + , isConnected + , isDisconnecting + , isDisconnected + , snapConnState + + -- * Concurrency + , fork + + -- * Lenses + , snapshot + , snapshotModify + , get + , set + , modify + ) where + +import Control.Concurrent (ThreadId, forkFinally, myThreadId) +import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Network.IRC.Conduit (Event(..), Message(..), + Source(..)) +import Network.IRC.CTCP (toCTCP) + +import Network.IRC.Client.Internal +import Network.IRC.Client.Lens + +------------------------------------------------------------------------------- +-- Nicks + +-- | Update the nick in the instance configuration and also send an +-- update message to the server. This doesn't attempt to resolve nick +-- collisions, that's up to the event handlers. +setNick :: Text -> IRC s () +setNick new = do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (set nick new) + send $ Nick new + + +------------------------------------------------------------------------------- +-- Channels + +-- | Update the channel list in the instance configuration and also +-- part the channel. +leaveChannel :: Text -> Maybe Text -> IRC s () +leaveChannel chan reason = do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ delChan tvarI chan + send $ Part chan reason + +-- | Remove a channel from the list without sending a part command (be +-- careful not to let the channel list get out of sync with the +-- real-world state if you use it for anything!) +delChan :: TVar (InstanceConfig s) -> Text -> STM () +delChan tvarI chan = + modifyTVar tvarI (modify channels (filter (/=chan))) + + +------------------------------------------------------------------------------- +-- Events + +-- | Add an event handler +addHandler :: EventHandler s -> IRC s () +addHandler handler = do + tvarI <- get instanceConfig <$> getIRCState + liftIO . atomically $ + modifyTVar tvarI (modify handlers (handler:)) + +-- | Send a message to the source of an event. +reply :: Event Text -> Text -> IRC s () +reply = replyTo . _source + +-- | Send a message to the source of an event. +replyTo :: Source Text -> Text -> IRC s () +replyTo (Channel c _) = mapM_ (send . Privmsg c . Right) . T.lines +replyTo (User n) = mapM_ (send . Privmsg n . Right) . T.lines +replyTo _ = const $ pure () + + +------------------------------------------------------------------------------- +-- CTCPs + +-- | Construct a @PRIVMSG@ containing a CTCP +ctcp :: Text -> Text -> [Text] -> Message Text +ctcp t command args = Privmsg t . Left $ toCTCP command args + +-- | Construct a @NOTICE@ containing a CTCP +ctcpReply :: Text -> Text -> [Text] -> Message Text +ctcpReply t command args = Notice t . Left $ toCTCP command args + + +------------------------------------------------------------------------------- +-- Connection state + +-- | Check if the client is connected. +isConnected :: IRC s Bool +isConnected = (==Connected) <$> snapConnState + +-- | Check if the client is in the process of disconnecting. +isDisconnecting :: IRC s Bool +isDisconnecting = (==Disconnecting) <$> snapConnState + +-- | Check if the client is disconnected +isDisconnected :: IRC s Bool +isDisconnected = (==Disconnected) <$> snapConnState + +-- | Snapshot the connection state. +snapConnState :: IRC s ConnectionState +snapConnState = liftIO . atomically . getConnectionState =<< getIRCState + + +------------------------------------------------------------------------------- +-- Concurrency + +-- | Fork a thread which will be thrown a 'Disconnect' exception when +-- the client disconnects. +fork :: IRC s () -> IRC s ThreadId +fork ma = do + s <- getIRCState + liftIO $ do + tid <- forkFinally (runIRCAction ma s) $ \_ -> do + tid <- myThreadId + atomically $ modifyTVar (_runningThreads s) (S.delete tid) + atomically $ modifyTVar (_runningThreads s) (S.insert tid) + pure tid diff --git a/deps/irc-client/README.markdown b/deps/irc-client/README.markdown new file mode 100644 index 0000000..36e294f --- /dev/null +++ b/deps/irc-client/README.markdown @@ -0,0 +1,44 @@ +**This project is essentially abandonware!** + +I may respond to minor issues, like version bounds which need +changing, but I won't be doing any significant work. + +Offer to take over the package if you want any significant changes. + +[irc-client][] +=========== + +An IRC client library. + + - Built on [irc-conduit][]. + + - Handles a connection to a single IRC server. + + - Manages "event handlers", calling them as appropriate on receipt of + messages. + + - Provides default event handlers for some common messages (e.g., + server PINGs). + + - Executes each event handler in its own thread, and uses a message + queue to guarantee thread-safe message delivery. + + - Provides a few helper functions for common operations. + +Note +---- + +This used to be a part of [yukibot][], so if you want the history from +before this was split out into its own library, check there. + +Contributing +------------ + +Bug reports, pull requests, and comments are very welcome! + +Feel free to contact me on GitHub, through IRC (#haskell on +libera.chat), or email (mike@barrucadu.co.uk). + +[irc-client]: https://hackage.haskell.org/package/irc-client +[irc-conduit]: https://hackage.haskell.org/package/irc-conduit +[yukibot]: https://github.com/barrucadu/yukibot diff --git a/deps/irc-client/Setup.hs b/deps/irc-client/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/deps/irc-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deps/irc-client/concourse/pipeline.yml b/deps/irc-client/concourse/pipeline.yml new file mode 100644 index 0000000..b27ac41 --- /dev/null +++ b/deps/irc-client/concourse/pipeline.yml @@ -0,0 +1,121 @@ +############################################################################### +## Tasks + +x-generic-task: &generic-task + platform: linux + image_resource: + type: docker-image + source: + repository: haskell + inputs: + - name: source-git + +x-task-build-and-test: &task-build-and-test + <<: *generic-task + run: + dir: source-git + path: sh + args: + - -cxe + - | + export LANG=C.UTF-8 + stack="stack --no-terminal" + + if [ -f ../stackage-feed/item ]; then + apt-get update && apt-get install -y jq + resolver="$(jq -r .id < ../stackage-feed/item | cut -d/ -f4)" + $stack init --resolver="$resolver" --force + fi + + $stack setup --install-ghc + $stack build + +############################################################################### +## Pipeline + +resource_types: + - name: feed-resource + type: docker-image + source: + repository: registry.barrucadu.dev/feed-resource + username: registry + password: ((docker-registry-password)) + +resources: + - name: stackage-feed + type: feed-resource + source: + uri: https://www.stackage.org/feed + - name: irc-client-git + type: git + source: + uri: https://github.com/barrucadu/irc-client.git + - name: irc-client-cabal-git + type: git + source: + uri: https://github.com/barrucadu/irc-client.git + paths: + - irc-client.cabal + +jobs: + - name: update-pipeline + plan: + - get: irc-client-git + trigger: true + - set_pipeline: irc-client + file: irc-client-git/concourse/pipeline.yml + + - name: test-snapshot + plan: + - get: irc-client-git + trigger: true + - get: stackage-feed + trigger: true + - task: build-and-test + input_mapping: + source-git: irc-client-git + config: + <<: *task-build-and-test + inputs: + - name: stackage-feed + - name: source-git + + - name: test + plan: + - get: irc-client-cabal-git + trigger: true + - task: build-and-test + input_mapping: + source-git: irc-client-cabal-git + config: + <<: *task-build-and-test + + - name: release + plan: + - get: irc-client-cabal-git + trigger: true + passed: + - test + - task: release + input_mapping: + source-git: irc-client-cabal-git + config: + <<: *generic-task + params: + HACKAGE_USERNAME: barrucadu + HACKAGE_PASSWORD: ((hackage-password)) + run: + dir: source-git + path: sh + args: + - -cxe + - | + ver=$(grep '^version:' irc-client.cabal | sed 's/^version: *//') + + if curl -fs "http://hackage.haskell.org/package/irc-client-${ver}" >/dev/null; then + echo "version already exists on hackage" >&2 + exit 0 + fi + + stack --no-terminal setup --install-ghc + echo n | stack --no-terminal upload . diff --git a/deps/irc-client/irc-client.cabal b/deps/irc-client/irc-client.cabal new file mode 100644 index 0000000..8dadc78 --- /dev/null +++ b/deps/irc-client/irc-client.cabal @@ -0,0 +1,127 @@ +-- Initial idte.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: irc-client + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 1.1.2.3 + +-- A short (one-line) description of the package. +synopsis: An IRC client library. + +-- A longer description of the package. +description: + An IRC client library built atop + <http://hackage.haskell.org/package/irc-conduit irc-conduit>. Why + another IRC client library, you cry? I didn't really find one that + did what I wanted (specifically, handle connecting to servers and + calling event handlers, possibly with TLS), but which didn't + implement almost a full IRC bot for you. That takes out all the fun! + . + <http://hackage.haskell.org/package/irc-conduit irc-conduit> and + <http://hackage.haskell.org/package/irc-ctcp irc-ctcp> are my + solution to the first part of that, this is my solution to the + latter. It's a simple IRC client library that does the basics for + you, but isn't an all-singing, all-dancing, fully-featured IRC + /application/. It is a merely a simple library. + +-- URL for the project homepage or repository. +homepage: https://github.com/barrucadu/irc-client + +-- URL where users should direct bug reports. +bug-reports: https://github.com/barrucadu/irc-client/issues + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Michael Walker + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: mike@barrucadu.co.uk + +-- A copyright notice. +-- copyright: + +category: Network + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Network.IRC.Client + , Network.IRC.Client.Events + , Network.IRC.Client.Internal + , Network.IRC.Client.Internal.Lens + , Network.IRC.Client.Internal.Types + , Network.IRC.Client.Lens + , Network.IRC.Client.Utils + + -- Modules included in this library but not exported. + other-modules: + Paths_irc_client + + -- Compile with -Wall by default + ghc-options: -Wall + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + , bytestring + , containers + , conduit + , connection + , contravariant + , exceptions + , irc-conduit + , irc-ctcp + , mtl + , network-conduit-tls + , old-locale + , profunctors + , stm + , stm-chans + , text + , time + , tls + , transformers + , x509 + , x509-store + , x509-validation + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/barrucadu/irc-client.git + +source-repository this + type: git + location: https://github.com/barrucadu/irc-client.git + tag: 1.1.2.3 diff --git a/deps/irc-client/stack.yaml b/deps/irc-client/stack.yaml new file mode 100644 index 0000000..66f399e --- /dev/null +++ b/deps/irc-client/stack.yaml @@ -0,0 +1,9 @@ +flags: {} +packages: +- '.' +extra-deps: +- irc-conduit-0.3.0.6 +resolver: lts-20.0 +nix: + enable: false + packages: [zlib] diff --git a/deps/irc-conduit/.github/dependabot.yml b/deps/irc-conduit/.github/dependabot.yml new file mode 100644 index 0000000..da0b496 --- /dev/null +++ b/deps/irc-conduit/.github/dependabot.yml @@ -0,0 +1,7 @@ +version: 2 +updates: + - package-ecosystem: github-actions + directory: / + schedule: + interval: daily + diff --git a/deps/irc-conduit/.github/workflows/ci.yaml b/deps/irc-conduit/.github/workflows/ci.yaml new file mode 100644 index 0000000..9034267 --- /dev/null +++ b/deps/irc-conduit/.github/workflows/ci.yaml @@ -0,0 +1,31 @@ +name: Run tests + +on: pull_request + +jobs: + lint: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2.4.3 + with: + enable-stack: true + - name: Setup + run: | + stack --no-terminal install stylish-haskell hlint + - name: Lint + run: | + set -ex + stack --no-terminal exec -- hlint --no-summary . + stack --no-terminal exec -- find . -name '*.hs' -exec stylish-haskell -i {} \; + git diff --exit-code + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: haskell/actions/setup@v2.4.3 + with: + enable-stack: true + - name: Build + run: | + stack --no-terminal build diff --git a/deps/irc-conduit/.gitignore b/deps/irc-conduit/.gitignore new file mode 100644 index 0000000..afaa85d --- /dev/null +++ b/deps/irc-conduit/.gitignore @@ -0,0 +1,4 @@ +.cabal-sandbox +cabal.sandbox.config +dist +.stack-work diff --git a/deps/irc-conduit/.stylish-haskell.yaml b/deps/irc-conduit/.stylish-haskell.yaml new file mode 100644 index 0000000..2d3ca44 --- /dev/null +++ b/deps/irc-conduit/.stylish-haskell.yaml @@ -0,0 +1,56 @@ +# stylish-haskell configuration file +# https://github.com/jaspervdj/stylish-haskell +########################## + +steps: + # Import cleanup + - imports: + # Align the import names and import list throughout the entire + # file. + align: global + + # Import list is aligned with end of import including 'as' and + # 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + list_align: after_alias + + # Put as many import specs on same line as possible. + long_list_align: inline + + # () is right after the module name: + # + # > import Vector.Instances () + empty_list_align: right_after + + # Align import list on lines after the import under the start of + # the module name. + list_padding: module_name + + # There is no space between classes and constructors and the + # list of it's members. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + separate_lists: false + + # Language pragmas + - language_pragmas: + # Vertical-spaced language pragmas, one per line. + style: vertical + + # Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + align: false + + # Remove redundant language pragmas. + remove_redundant: true + + # Remove trailing whitespace + - trailing_whitespace: {} + +# Maximum line length, used by some of the steps above. +columns: 80 + +# Convert newlines to LF ("\n"). +newline: lf diff --git a/deps/irc-conduit/LICENSE b/deps/irc-conduit/LICENSE new file mode 100644 index 0000000..03c030a --- /dev/null +++ b/deps/irc-conduit/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014, Michael Walker <mike@barrucadu.co.uk> + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/deps/irc-conduit/Network/IRC/Conduit.hs b/deps/irc-conduit/Network/IRC/Conduit.hs new file mode 100644 index 0000000..1185749 --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : OverloadedStrings, RankNTypes +-- +-- Conduits for serialising and deserialising IRC messages. +-- +-- The 'Event', 'Message', and 'Source' types are parameterised on the +-- underlying representation, and are functors. Decoding and encoding +-- only work in terms of 'ByteString's, but the generality is provided +-- so that programs using this library can operate in terms of 'Text', +-- or some other more useful representation, with great ease. +module Network.IRC.Conduit + ( -- *Type synonyms + ChannelName + , NickName + , ServerName + , Reason + , IsModeSet + , ModeFlag + , ModeArg + , NumericArg + , Target + , IrcEvent + , IrcSource + , IrcMessage + + -- *Messages + , Event(..) + , Source(..) + , Message(..) + + -- *Conduits + , ircDecoder + , ircLossyDecoder + , ircEncoder + , floodProtector + + -- *Networking + , ircClient + , ircWithConn + -- ** TLS + , ircTLSClient + , ircTLSClient' + , defaultTLSConfig + + -- *Utilities + , rawMessage + , toByteString + + -- *Lenses + , module Network.IRC.Conduit.Lens + ) where + +import Control.Applicative ((*>)) +import Control.Concurrent (newMVar, putMVar, takeMVar, + threadDelay) +import Control.Concurrent.Async (Concurrently(..)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.Conduit (ConduitM, awaitForever, + runConduit, yield, (.|)) +import Data.Conduit.Network (AppData, appSink, appSource, + clientSettings, runTCPClient) +import Data.Conduit.Network.TLS (TLSClientConfig(..), + runTLSClient, tlsClientConfig) +import Data.Monoid ((<>)) +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock (NominalDiffTime, addUTCTime, + diffUTCTime, getCurrentTime) +import Data.Void (Void) +import Data.X509.Validation (FailedReason(..)) +import Network.Connection (TLSSettings(..)) +import Network.IRC.Conduit.Internal +import Network.IRC.Conduit.Lens +import Network.TLS (ClientHooks(..), + ClientParams(..), Supported(..), + Version(..), defaultParamsClient) +import Network.TLS.Extra (ciphersuite_strong) + +-- *Conduits + +-- |A conduit which takes as input bytestrings representing encoded +-- IRC messages, and decodes them to events. If decoding fails, the +-- original bytestring is just passed through. +ircDecoder :: Monad m => ConduitM ByteString (Either ByteString IrcEvent) m () +ircDecoder = chunked .| awaitForever (yield . fromByteString) + +-- |Like 'ircDecoder', but discards messages which could not be +-- decoded. +ircLossyDecoder :: Monad m => ConduitM ByteString IrcEvent m () +ircLossyDecoder = chunked .| awaitForever lossy + where + lossy bs = either (\_ -> return ()) yield $ fromByteString bs + +-- |A conduit which takes as input irc messages, and produces as +-- output the encoded bytestring representation. +ircEncoder :: Monad m => ConduitM IrcMessage ByteString m () +ircEncoder = awaitForever (yield . (<>"\r\n") . toByteString) + +-- |A conduit which rate limits output sent downstream. Awaiting on +-- this conduit will block, even if there is output ready, until the +-- time limit has passed. +floodProtector :: MonadIO m + => NominalDiffTime + -- ^The minimum time between sending adjacent messages. + -> IO (ConduitM a a m ()) +floodProtector delay = do + now <- getCurrentTime + mvar <- newMVar now + + return $ conduit mvar + + where + conduit mvar = awaitForever $ \val -> do + -- Block until the delay has passed + liftIO $ do + lastT <- takeMVar mvar + now <- getCurrentTime + + let next = addUTCTime delay lastT + + when (now < next) $ + threadDelay . ceiling $ 1000000 * diffUTCTime next now + + -- Update the time + now' <- getCurrentTime + putMVar mvar now' + + -- Send the value downstream + yield val + +-- *Networking + +-- |Connect to a network server, without TLS, and concurrently run the +-- producer and consumer. +ircClient :: Int + -- ^The port number + -> ByteString + -- ^The hostname + -> IO () + -- ^Any initialisation work (started concurrently with the + -- producer and consumer) + -> ConduitM (Either ByteString IrcEvent) Void IO () + -- ^The consumer of irc events + -> ConduitM () IrcMessage IO () + -- ^The producer of irc messages + -> IO () +ircClient port host = ircWithConn $ runTCPClient $ clientSettings port host + +-- |Run the IRC conduits using a provided connection. +-- +-- Starts the connection and concurrently run the initialiser, event +-- consumer, and message sources. Terminates as soon as one throws an +-- exception. +ircWithConn :: ((AppData -> IO ()) -> IO ()) + -- ^The initialised connection. + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircWithConn runner start cons prod = runner $ \appdata -> runConcurrently $ + Concurrently start + *> Concurrently (runSource appdata) + *> Concurrently (runSink appdata) + + where + runSource appdata = do + runConduit $ appSource appdata .| ircDecoder .| cons + ioError $ userError "Upstream source closed." + + runSink appdata = + runConduit $ prod .| ircEncoder .| appSink appdata + +-- **TLS + +-- |Like 'ircClient', but with TLS. The TLS configuration used is +-- 'defaultTLSConfig'. +ircTLSClient :: Int + -> ByteString + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircTLSClient port host = ircTLSClient' (defaultTLSConfig port host) + +-- |Like 'ircTLSClient', but takes the configuration to use, which +-- includes the host and port. +ircTLSClient' :: TLSClientConfig + -> IO () + -> ConduitM (Either ByteString IrcEvent) Void IO () + -> ConduitM () IrcMessage IO () + -> IO () +ircTLSClient' cfg = ircWithConn (runTLSClient cfg) + +-- |The default TLS settings for 'ircTLSClient'. +defaultTLSConfig :: Int + -- ^The port number + -> ByteString + -- ^ The hostname + -> TLSClientConfig +defaultTLSConfig port host = (tlsClientConfig port host) + { tlsClientTLSSettings = TLSSettings cpara + { clientHooks = (clientHooks cpara) + { onServerCertificate = validate } + , clientSupported = (clientSupported cpara) + { supportedVersions = [TLS12, TLS11, TLS10] + , supportedCiphers = ciphersuite_strong + } + } + } + + where + cpara = defaultParamsClient (unpack $ decodeUtf8 host) "" + + -- Make the TLS certificate validation a bit more generous. In + -- particular, allow self-signed certificates. + validate cs vc sid cc = do + -- First validate with the standard function + res <- (onServerCertificate $ clientHooks cpara) cs vc sid cc + -- Then strip out non-issues + return $ filter (`notElem` [UnknownCA, SelfSigned]) res diff --git a/deps/irc-conduit/Network/IRC/Conduit/Internal.hs b/deps/irc-conduit/Network/IRC/Conduit/Internal.hs new file mode 100644 index 0000000..3b9eabf --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit/Internal.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Network.IRC.Conduit.Internal +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : BangPatterns, DeriveFunctor, OverloadedStrings, RankNTypes, TupleSections +-- +-- Internal IRC conduit types and utilities. This module is NOT +-- considered to form part of the public interface of this library. +module Network.IRC.Conduit.Internal where + +import Control.Applicative ((<$>)) +import Control.Arrow ((&&&)) +import Data.ByteString (ByteString, isSuffixOf, singleton, + unpack) +import Data.Char (ord) +import Data.Conduit (ConduitM, await, yield) +import Data.Maybe (isJust, listToMaybe) +import Data.Monoid ((<>)) +import Data.Profunctor (Choice) +import Data.String (fromString) +import Network.IRC.CTCP (CTCPByteString, getUnderlyingByteString, + orCTCP) +import Text.Read (readMaybe) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Network.IRC as I + +-- * Internal Lens synonyms + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Control.Lens.Lens.Lens>@. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Lens'. +type Lens' s a = Lens s s a a + +-- | See @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Prism.html#t:Prism Control.Lens.Prism.Prism>@. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A @<http://hackage.haskell.org/package/lens/docs/Control-Lens-Type.html#t:Simple Simple>@ 'Prism'. +type Prism' s a = Prism s s a a + + +-- *Conduits + +-- |Split up incoming bytestrings into new lines. +chunked :: Monad m => ConduitM ByteString ByteString m () +chunked = chunked' "" + where + chunked' !leftover = do + -- Wait for a value from upstream + val <- await + + case val of + Just val' -> + let + carriage = fromIntegral $ fromEnum '\r' + newline = fromIntegral $ fromEnum '\n' + + -- Split on '\n's, removing any stray '\r's (line endings + -- are usually '\r\n's, but this isn't certain). + bytes = B.filter (/=carriage) $ leftover <> val' + splitted = B.split newline bytes + + -- If the last chunk ends with a '\n', then we have a + -- complete message at the end, and can yield it + -- immediately. Otherwise, store the partial message to + -- prepend to the next bytestring received. + (toyield, remainder) + | singleton newline `isSuffixOf` bytes = (splitted, "") + | otherwise = init &&& last $ splitted + + in do + -- Yield all complete and nonempty messages, and loop. + mapM_ yield $ filter (not . B.null) toyield + chunked' remainder + + Nothing -> return () + +-- *Type synonyms +type ChannelName a = a +type NickName a = a +type ServerName a = a +type Reason a = Maybe a +type IsModeSet = Bool +type ModeFlag a = a +type ModeArg a = a +type NumericArg a = a + +-- |The target of a message. Will be a nick or channel name. +type Target a = a + +type IrcEvent = Event ByteString +type IrcSource = Source ByteString +type IrcMessage = Message ByteString + +-- *Messages + +-- |A decoded IRC message + source. +data Event a = Event + { _raw :: ByteString + -- ^The message as a bytestring. + , _source :: Source a + -- ^The source of the message (user, channel, or server). + , _message :: Message a + -- ^The decoded message. This will never be a 'RawMsg'. + } + deriving (Eq, Functor, Show) + +-- |The source of an IRC message. +data Source a = User (NickName a) + -- ^The message comes directly from a user. + | Channel (ChannelName a) (NickName a) + -- ^The message comes from a user in a channel. + | Server (ServerName a) + -- ^The message comes directly from the server. + deriving (Eq, Functor, Show) + +-- |A decoded IRC message. +data Message a = Privmsg (Target a) (Either CTCPByteString a) + -- ^A message, either from a user or to a channel the + -- client is in. CTCPs are distinguished by starting + -- and ending with a \\001 (SOH). + | Notice (Target a) (Either CTCPByteString a) + -- ^Like a privmsg, but should not provoke an automatic + -- response. + | Nick (NickName a) + -- ^Someone has updated their nick. + | Join (ChannelName a) + -- ^Someone has joined a channel. + | Part (ChannelName a) (Reason a) + -- ^Someone has left a channel. + | Quit (Reason a) + -- ^Someone has left the network. + | Mode (Target a) IsModeSet [ModeFlag a] [ModeArg a] + -- ^Someone has set some channel modes or user modes. + | Topic (ChannelName a) a + -- ^Someone has set the topic of a channel. + | Invite (ChannelName a) (NickName a) + -- ^The client has been invited to a channel. + | Kick (ChannelName a) (NickName a) (Reason a) + -- ^Someone has been kicked from a channel. + | Ping (ServerName a) (Maybe (ServerName a)) + -- ^The client has received a server ping, and should + -- send a pong asap. + | Pong (ServerName a) + -- ^A pong sent to the named server. + | Numeric Int [NumericArg a] + -- ^One of the many server numeric responses. + | RawMsg a + -- ^Never produced by decoding, but can be used to send + -- arbitrary bytestrings to the IRC server. Naturally, + -- this should only be used when you are confident that + -- the produced bytestring will be a valid IRC message. + deriving (Eq, Functor, Show) + +-- *Decoding messages + +fromByteString :: ByteString -> Either ByteString IrcEvent +fromByteString bs = maybe (Left bs) (Right . uncurry (Event bs)) (attemptDecode bs) + +-- |Attempt to decode a ByteString into a message, returning a Nothing +-- if either the source or the message can't be determined. +attemptDecode :: ByteString -> Maybe (IrcSource, IrcMessage) +attemptDecode bs = I.decode bs >>= decode' + where + decode' msg = case msg of + -- Disambiguate PRIVMSG and NOTICE source by checking the first + -- character of the target + I.Message (Just (I.NickName n _ _)) "PRIVMSG" [t, m] | isChan t -> Just (Channel t n, privmsg t m) + | otherwise -> Just (User n, privmsg t m) + + I.Message (Just (I.NickName n _ _)) "NOTICE" [t, m] | isChan t -> Just (Channel t n, notice t m) + | otherwise -> Just (User n, notice t m) + + I.Message (Just (I.NickName n _ _)) "NICK" [n'] -> Just (User n, Nick n') + I.Message (Just (I.NickName n _ _)) "JOIN" [c] -> Just (Channel c n, Join c) + I.Message (Just (I.NickName n _ _)) "PART" (c:r) -> Just (Channel c n, Part c $ listToMaybe r) + I.Message (Just (I.NickName n _ _)) "QUIT" r -> Just (User n, Quit $ listToMaybe r) + I.Message (Just (I.NickName n _ _)) "KICK" (c:u:r) -> Just (Channel c n, Kick c u $ listToMaybe r) + I.Message (Just (I.NickName n _ _)) "INVITE" [_, c] -> Just (User n, Invite c n) + I.Message (Just (I.NickName n _ _)) "TOPIC" [c, t] -> Just (Channel c n, Topic c t) + + I.Message (Just (I.NickName n _ _)) "MODE" (t:fs:as) | n == t -> (User n,) <$> mode t fs as + | otherwise -> (Channel t n,) <$> mode t fs as + + I.Message (Just (I.Server s)) "PING" (s1:s2) -> Just (Server s, Ping s1 $ listToMaybe s2) + I.Message Nothing "PING" (s1:s2) -> Just (Server s1, Ping s1 $ listToMaybe s2) + + I.Message (Just (I.Server s)) n args | isNumeric n -> (Server s,) <$> numeric n args + + _ -> Nothing + + -- An IRC channel name can start with '#', '&', '+', or '!', all + -- of which have different meanings. However, most servers only + -- support '#'. + isChan t = B.take 1 t `elem` ["#", "&", "+", "!"] + + -- Check if the message looks like a ctcp or not, and produce the appropriate message type. + privmsg t = Privmsg t . (Right `orCTCP` Left) + notice t = Notice t . (Right `orCTCP` Left) + + -- Decode a set of mode changes + mode t fs as = case unpack fs of + (f:fs') | f == fromIntegral (ord '+') -> Just $ Mode t True (map singleton fs') as + | f == fromIntegral (ord '-') -> Just $ Mode t False (map singleton fs') as + _ -> Nothing + + -- Parse the number in a numeric response + isNumeric = isJust . (readMaybe :: String -> Maybe Int) . B8.unpack + numeric n args = flip Numeric args <$> readMaybe (B8.unpack n) + +-- *Encoding messages + +-- |Encode an IRC message into a single bytestring suitable for +-- sending to the server. +toByteString :: IrcMessage -> ByteString +toByteString (Privmsg t (Left ctcpbs)) = mkMessage "PRIVMSG" [t, getUnderlyingByteString ctcpbs] +toByteString (Privmsg t (Right bs)) = mkMessage "PRIVMSG" [t, bs] +toByteString (Notice t (Left ctcpbs)) = mkMessage "NOTICE" [t, getUnderlyingByteString ctcpbs] +toByteString (Notice t (Right bs)) = mkMessage "NOTICE" [t, bs] +toByteString (Nick n) = mkMessage "NICK" [n] +toByteString (Join c) = mkMessage "JOIN" [c] +toByteString (Part c (Just r)) = mkMessage "PART" [c, r] +toByteString (Part c Nothing) = mkMessage "PART" [c] +toByteString (Quit (Just r)) = mkMessage "QUIT" [r] +toByteString (Quit Nothing) = mkMessage "QUIT" [] +toByteString (Mode t True ms as) = mkMessage "MODE" $ t : ("+" <> B.concat ms) : as +toByteString (Mode t False ms as) = mkMessage "MODE" $ t : ("-" <> B.concat ms) : as +toByteString (Invite c n) = mkMessage "INVITE" [c, n] +toByteString (Topic c bs) = mkMessage "TOPIC" [c, bs] +toByteString (Kick c n (Just r)) = mkMessage "KICK" [c, n, r] +toByteString (Kick c n Nothing) = mkMessage "KICK" [c, n] +toByteString (Ping s1 (Just s2)) = mkMessage "PING" [s1, s2] +toByteString (Ping s1 Nothing) = mkMessage "PING" [s1] +toByteString (Pong s) = mkMessage "PONG" [s] +toByteString (Numeric n as) = mkMessage (fromString $ show n) as +toByteString (RawMsg bs) = bs + +mkMessage :: ByteString -> [ByteString] -> ByteString +mkMessage cmd = I.encode . I.Message Nothing cmd + +-- |Construct a raw message. +rawMessage :: ByteString + -- ^The command + -> [ByteString] + -- ^The arguments + -> IrcMessage +rawMessage cmd = RawMsg . mkMessage cmd diff --git a/deps/irc-conduit/Network/IRC/Conduit/Lens.hs b/deps/irc-conduit/Network/IRC/Conduit/Lens.hs new file mode 100644 index 0000000..deb4ae1 --- /dev/null +++ b/deps/irc-conduit/Network/IRC/Conduit/Lens.hs @@ -0,0 +1,157 @@ +-- | +-- Module : Network.IRC.Conduit +-- Copyright : (c) 2017 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker <mike@barrucadu.co.uk> +-- Stability : experimental +-- Portability : portable +-- +-- 'Lens'es and 'Prism's. +module Network.IRC.Conduit.Lens where + +import Data.ByteString (ByteString) +import Data.Profunctor (Choice(right'), + Profunctor(dimap)) + +import Network.IRC.Conduit.Internal +import Network.IRC.CTCP (CTCPByteString) + +-- * Lenses for 'Event' + +-- | 'Lens' for '_raw'. +raw :: Lens' (Event a) ByteString +{-# INLINE raw #-} +raw afb s = (\b -> s { _raw = b }) <$> afb (_raw s) + +-- | 'Lens' for '_source'. +source :: Lens' (Event a) (Source a) +{-# INLINE source #-} +source afb s = (\b -> s { _source = b }) <$> afb (_source s) + +-- | 'Lens' for '_message'. +message :: Lens' (Event a) (Message a) +{-# INLINE message #-} +message afb s = (\b -> s { _message = b }) <$> afb (_message s) + +-- * Prisms for 'Source' + +-- | 'Prism' for 'User' +_User :: Prism' (Source a) (NickName a) +{-# INLINE _User #-} +_User = dimap + (\s -> case s of User n -> Right n; _ -> Left s) + (either pure $ fmap User) . right' + +-- | 'Prism' for 'Channel' +_Channel :: Prism' (Source a) (ChannelName a, NickName a) +{-# INLINE _Channel #-} +_Channel = dimap + (\s -> case s of Channel c n -> Right (c,n); _ -> Left s) + (either pure $ fmap (uncurry Channel)) . right' + +-- | 'Prism' for 'Server' +_Server :: Prism' (Source a) (ServerName a) +{-# INLINE _Server #-} +_Server = dimap + (\s -> case s of Server n -> Right n; _ -> Left s) + (either pure $ fmap Server) . right' + +-- * Prisms for 'Message' + +-- | 'Prism' for 'Privmsg' +_Privmsg :: Prism' (Message a) (Target a, Either CTCPByteString a) +{-# INLINE _Privmsg #-} +_Privmsg = dimap + (\s -> case s of Privmsg t m -> Right (t,m); _ -> Left s) + (either pure $ fmap (uncurry Privmsg)) . right' + +-- | 'Prism' for 'Notice' +_Notice :: Prism' (Message a) (Target a, Either CTCPByteString a) +{-# INLINE _Notice #-} +_Notice = dimap + (\s -> case s of Notice t m -> Right (t,m); _ -> Left s) + (either pure $ fmap (uncurry Notice)) . right' + +-- | 'Prism' for 'Nick' +_Nick :: Prism' (Message a) (NickName a) +{-# INLINE _Nick #-} +_Nick = dimap + (\s -> case s of Nick n -> Right n; _ -> Left s) + (either pure $ fmap Nick) . right' + +-- | 'Prism' for 'Join' +_Join :: Prism' (Message a) (ChannelName a) +{-# INLINE _Join #-} +_Join = dimap + (\s -> case s of Join c -> Right c; _ -> Left s) + (either pure $ fmap Join) . right' + +-- | 'Prism' for 'Part' +_Part :: Prism' (Message a) (ChannelName a, Reason a) +{-# INLINE _Part #-} +_Part = dimap + (\s -> case s of Part c r -> Right (c,r); _ -> Left s) + (either pure $ fmap (uncurry Part)) . right' + +-- | 'Prism' for 'Quit' +_Quit :: Prism' (Message a) (Reason a) +{-# INLINE _Quit #-} +_Quit = dimap + (\s -> case s of Quit r -> Right r; _ -> Left s) + (either pure $ fmap Quit) . right' + +-- | 'Prism' for 'Mode' +_Mode :: Prism' (Message a) (Target a, IsModeSet, [ModeFlag a], [ModeArg a]) +{-# INLINE _Mode #-} +_Mode = dimap + (\s -> case s of Mode t i f a -> Right (t,i,f,a); _ -> Left s) + (either pure $ fmap (\(t,i,f,a) -> Mode t i f a)) . right' + +-- | 'Prism' for 'Topic' +_Topic :: Prism' (Message a) (ChannelName a, a) +{-# INLINE _Topic #-} +_Topic = dimap + (\s -> case s of Topic c t -> Right (c,t); _ -> Left s) + (either pure $ fmap (uncurry Topic)) . right' + +-- | 'Prism' for 'Invite' +_Invite :: Prism' (Message a) (ChannelName a, NickName a) +{-# INLINE _Invite #-} +_Invite = dimap + (\s -> case s of Invite c n -> Right (c,n); _ -> Left s) + (either pure $ fmap (uncurry Invite)) . right' + +-- | 'Prism' for 'Kick' +_Kick :: Prism' (Message a) (ChannelName a, NickName a, Reason a) +{-# INLINE _Kick #-} +_Kick = dimap + (\s -> case s of Kick c n r -> Right (c,n,r); _ -> Left s) + (either pure $ fmap (\(c,n,r) -> Kick c n r)) . right' + +-- | 'Prism' for 'Ping' +_Ping :: Prism' (Message a) (ServerName a, Maybe (ServerName a)) +{-# INLINE _Ping #-} +_Ping = dimap + (\s -> case s of Ping x y -> Right (x,y); _ -> Left s) + (either pure $ fmap (uncurry Ping)) . right' + +-- | 'Prism' for 'Pong' +_Pong :: Prism' (Message a) (ServerName a) +{-# INLINE _Pong #-} +_Pong = dimap + (\s -> case s of Pong x -> Right x; _ -> Left s) + (either pure $ fmap Pong) . right' + +-- | 'Prism' for 'Numeric' +_Numeric :: Prism' (Message a) (Int, [NumericArg a]) +{-# INLINE _Numeric #-} +_Numeric = dimap + (\s -> case s of Numeric n a -> Right (n,a); _ -> Left s) + (either pure $ fmap (uncurry Numeric)) . right' + +-- | 'Prism' for 'RawMsg' +_RawMsg :: Prism' (Message a) a +{-# INLINE _RawMsg #-} +_RawMsg = dimap + (\s -> case s of RawMsg a -> Right a; _ -> Left s) + (either pure $ fmap RawMsg) . right' diff --git a/deps/irc-conduit/README.markdown b/deps/irc-conduit/README.markdown new file mode 100644 index 0000000..73b61a0 --- /dev/null +++ b/deps/irc-conduit/README.markdown @@ -0,0 +1,40 @@ +**This project is essentially abandonware!** + +I may respond to minor issues, like version bounds which need +changing, but I won't be doing any significant work. + +Offer to take over the package if you want any significant changes. + +[irc-conduit][] +============ + +Streaming IRC message library using conduits. + + - Provides [conduits][conduit] for translating bytestrings into + "events", and "messages" into bytestrings. + + - Provides a sum type for all IRC messages you're likely to want to + deal with in a client. + + - Provides two helper functions for connecting to IRC servers + directly. + + - Manages flood protection when connecting to a server directly. + +Note +---- + +This used to be a part of [yukibot][], so if you want the history from +before this was split out into its own library, check there. + +Contributing +------------ + +Bug reports, pull requests, and comments are very welcome! + +Feel free to contact me on GitHub, through IRC (#haskell on +libera.chat), or email (mike@barrucadu.co.uk). + +[irc-conduit]: http://hackage.haskell.org/package/irc-conduit +[conduit]: https://hackage.haskell.org/package/conduit +[yukibot]: https://github.com/barrucadu/yukibot diff --git a/deps/irc-conduit/Setup.hs b/deps/irc-conduit/Setup.hs new file mode 100644 index 0000000..4467109 --- /dev/null +++ b/deps/irc-conduit/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deps/irc-conduit/concourse/pipeline.yml b/deps/irc-conduit/concourse/pipeline.yml new file mode 100644 index 0000000..3298cb2 --- /dev/null +++ b/deps/irc-conduit/concourse/pipeline.yml @@ -0,0 +1,121 @@ +############################################################################### +## Tasks + +x-generic-task: &generic-task + platform: linux + image_resource: + type: docker-image + source: + repository: haskell + inputs: + - name: source-git + +x-task-build-and-test: &task-build-and-test + <<: *generic-task + run: + dir: source-git + path: sh + args: + - -cxe + - | + export LANG=C.UTF-8 + stack="stack --no-terminal" + + if [ -f ../stackage-feed/item ]; then + apt-get update && apt-get install -y jq + resolver="$(jq -r .id < ../stackage-feed/item | cut -d/ -f4)" + $stack init --resolver="$resolver" --force + fi + + $stack setup --install-ghc + $stack build + +############################################################################### +## Pipeline + +resource_types: + - name: feed-resource + type: docker-image + source: + repository: registry.barrucadu.dev/feed-resource + username: registry + password: ((docker-registry-password)) + +resources: + - name: stackage-feed + type: feed-resource + source: + uri: https://www.stackage.org/feed + - name: irc-conduit-git + type: git + source: + uri: https://github.com/barrucadu/irc-conduit.git + - name: irc-conduit-cabal-git + type: git + source: + uri: https://github.com/barrucadu/irc-conduit.git + paths: + - irc-conduit.cabal + +jobs: + - name: update-pipeline + plan: + - get: irc-conduit-git + trigger: true + - set_pipeline: irc-conduit + file: irc-conduit-git/concourse/pipeline.yml + + - name: test-snapshot + plan: + - get: irc-conduit-git + trigger: true + - get: stackage-feed + trigger: true + - task: build-and-test + input_mapping: + source-git: irc-conduit-git + config: + <<: *task-build-and-test + inputs: + - name: stackage-feed + - name: source-git + + - name: test + plan: + - get: irc-conduit-cabal-git + trigger: true + - task: build-and-test + input_mapping: + source-git: irc-conduit-cabal-git + config: + <<: *task-build-and-test + + - name: release + plan: + - get: irc-conduit-cabal-git + trigger: true + passed: + - test + - task: release + input_mapping: + source-git: irc-conduit-cabal-git + config: + <<: *generic-task + params: + HACKAGE_USERNAME: barrucadu + HACKAGE_PASSWORD: ((hackage-password)) + run: + dir: source-git + path: sh + args: + - -cxe + - | + ver=$(grep '^version:' irc-conduit.cabal | sed 's/^version: *//') + + if curl -fs "http://hackage.haskell.org/package/irc-conduit-${ver}" >/dev/null; then + echo "version already exists on hackage" >&2 + exit 0 + fi + + stack --no-terminal setup --install-ghc + echo n | stack --no-terminal upload . diff --git a/deps/irc-conduit/irc-conduit.cabal b/deps/irc-conduit/irc-conduit.cabal new file mode 100644 index 0000000..be71788 --- /dev/null +++ b/deps/irc-conduit/irc-conduit.cabal @@ -0,0 +1,111 @@ +-- Initial irc-conduit.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: irc-conduit + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.3.0.6 + +-- A short (one-line) description of the package. +synopsis: Streaming IRC message library using conduits. + +-- A longer description of the package. +description: + IRC messages consist of an optional identifying prefix, a command + name, and a list of arguments. The <http://hackage.haskell.org/package/irc irc> + package provides a low-level decoding and encoding scheme for + messages in terms of ByteStrings, but using this relies on matching + names of commands as strings, and unpacking this decoded structure + yourself. This package takes it a little further, providing an ADT + for IRC messages and sources, and conduits which attempt to decode + and encode messages appropriately. + . + In addition to providing conduits for automatically handling + streaming messages, there are also helper functions for connecting + to an IRC server and hooking up conduits to the socket. + +-- URL for the project homepage or repository. +homepage: https://github.com/barrucadu/irc-conduit + +-- URL where users should direct bug reports. +bug-reports: https://github.com/barrucadu/irc-conduit/issues + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Michael Walker + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: mike@barrucadu.co.uk + +-- A copyright notice. +-- copyright: + +category: Network + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Network.IRC.Conduit + , Network.IRC.Conduit.Internal + , Network.IRC.Conduit.Lens + + -- Modules included in this library but not exported. + -- other-modules: + + ghc-options: -Wall + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base + , async + , bytestring + , conduit + , conduit-extra + , connection + , irc + , irc-ctcp + , network-conduit-tls + , profunctors + , text + , time + , tls + , transformers + , x509-validation + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/barrucadu/irc-conduit.git + +source-repository this + type: git + location: https://github.com/barrucadu/irc-conduit.git + tag: 0.3.0.6 diff --git a/deps/irc-conduit/stack.yaml b/deps/irc-conduit/stack.yaml new file mode 100644 index 0000000..ca42daf --- /dev/null +++ b/deps/irc-conduit/stack.yaml @@ -0,0 +1,7 @@ +flags: {} +packages: +- '.' +resolver: lts-20.0 +nix: + enable: false + packages: [zlib] diff --git a/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal b/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal new file mode 100644 index 0000000..6a59f11 --- /dev/null +++ b/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal @@ -0,0 +1,47 @@ +cabal-version: 3.4 +name: fig-bridge-irc-discord +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , directory + , filepath + , megaparsec + , mtl + , network + , safe-exceptions + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Bridge.IRCDiscord + +executable fig-bridge-irc-discord + import: defaults + import: deps + build-depends: fig-bridge-irc-discord, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs
\ No newline at end of file diff --git a/fig-bridge-irc-discord/main/Main.hs b/fig-bridge-irc-discord/main/Main.hs new file mode 100644 index 0000000..8cd1fcb --- /dev/null +++ b/fig-bridge-irc-discord/main/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Bridge.IRCDiscord + +data Opts = Opts + { busHost :: Text + , busPort :: Text + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") + <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-bridge-irc-discord - bridge between IRC and Discord" + ) + bridge (opts.busHost, opts.busPort) diff --git a/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs b/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs new file mode 100644 index 0000000..b1e6c43 --- /dev/null +++ b/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs @@ -0,0 +1,32 @@ +{-# Language QuasiQuotes #-} + +module Fig.Bridge.IRCDiscord where + +import Fig.Prelude + +import Fig.Utils.SExpr +import Fig.Bus.Client + +bridge :: (Text, Text) -> IO () +bridge busAddr = do + busClient busAddr + (\cmds -> do + cmds.subscribe [sexp|(monitor irc chat incoming)|] + cmds.subscribe [sexp|(monitor discord chat incoming)|] + ) + (\cmds d -> do + case d of + SExprList [ev, user, _, msg] + | ev == [sexp|(monitor irc chat incoming)|] -> + cmds.publish [sexp|(monitor discord chat outgoing)|] + [ user + , msg + ] + | ev == [sexp|(monitor discord chat incoming)|] -> + cmds.publish [sexp|(monitor irc chat outgoing)|] + [ user + , msg + ] + _ -> log $ "Invalid message: " <> tshow d + ) + (pure ()) diff --git a/fig-bus/fig-bus.cabal b/fig-bus/fig-bus.cabal new file mode 100644 index 0000000..ec68ef5 --- /dev/null +++ b/fig-bus/fig-bus.cabal @@ -0,0 +1,45 @@ +cabal-version: 3.4 +name: fig-bus +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , binary + , bytestring + , containers + , directory + , containers + , directory + , filepath + , megaparsec + , mtl + , network + , safe-exceptions + , text + , time + , transformers + , unordered-containers + , vector + , fig-utils + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Bus + Fig.Bus.Client + +executable fig-bus + import: defaults + import: deps + build-depends: fig-bus, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs
\ No newline at end of file diff --git a/fig-bus/main/Main.hs b/fig-bus/main/Main.hs new file mode 100644 index 0000000..9f84fd2 --- /dev/null +++ b/fig-bus/main/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import qualified Fig.Bus + +data Opts = Opts + { host :: Text + , port :: Text + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "host" <> metavar "HOST" <> help "Interface to bind" <> value "localhost") + <*> strOption (long "port" <> metavar "PORT" <> help "Port to bind" <> showDefault <> value "32050") + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-bus - a pub/sub message bus" + ) + Fig.Bus.main (Just opts.host, opts.port) diff --git a/fig-bus/src/Fig/Bus.hs b/fig-bus/src/Fig/Bus.hs new file mode 100644 index 0000000..2102864 --- /dev/null +++ b/fig-bus/src/Fig/Bus.hs @@ -0,0 +1,62 @@ +module Fig.Bus (main) where + +import Fig.Prelude + +import Control.Concurrent.MVar as MVar + +import qualified Data.List as List +import Data.ByteString (hPut, hGetLine) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.IORef as IORef + +import Fig.Utils.SExpr +import Fig.Utils.Net + +newtype BusState = BusState + { subscriptions :: Map SExpr [Handle] + } + +subscribe :: SExpr -> Handle -> BusState -> BusState +subscribe ev h bs = bs + { subscriptions = Map.insertWith (<>) ev [h] bs.subscriptions + } + +unsubscribe :: SExpr -> Handle -> BusState -> BusState +unsubscribe ev h bs = bs + { subscriptions = Map.update (Just . List.delete h) ev bs.subscriptions + } + +publish :: SExpr -> [SExpr] -> BusState -> IO () +publish ev d bs = + case Map.lookup ev bs.subscriptions of + Nothing -> pure () + Just hs -> forM_ hs \h -> do + hPut h . encodeUtf8 $ pretty (SExprList $ ev:d) <> "\n" + +main :: (Maybe Text, Text) -> IO () +main bind = do + st <- MVar.newMVar $ BusState { subscriptions = Map.empty } + server bind do + subs <- IORef.newIORef ([] :: [SExpr]) + pure \h peer -> + ( do + forever do + line <- throwLeft id . decodeUtf8' =<< hGetLine h + case parseSExpr line of + Just (SExprList (SExprSymbol "ping":_)) -> do + log $ tshow peer <> " pinged" + hPut h . encodeUtf8 $ "(pong)\n" + Just (SExprList [SExprSymbol "sub", ev]) -> do + log $ tshow peer <> " subscribing to: " <> pretty ev + IORef.modifyIORef' subs (ev:) + MVar.modifyMVar_ st (pure . subscribe ev h) + Just (SExprList (SExprSymbol "pub":ev:d)) -> do + log $ tshow peer <> " publishing " <> pretty (SExprList d) <> " to: " <> pretty ev + publish ev d =<< MVar.readMVar st + Just x -> log $ tshow peer <> " sent invalid command: " <> pretty x + Nothing -> log $ tshow peer <> " sent malformed s-expression: " <> line + , do + ss <- IORef.readIORef subs + MVar.modifyMVar_ st \bs -> pure $ foldr (`unsubscribe` h) bs ss + ) diff --git a/fig-bus/src/Fig/Bus/Client.hs b/fig-bus/src/Fig/Bus/Client.hs new file mode 100644 index 0000000..6d72ad4 --- /dev/null +++ b/fig-bus/src/Fig/Bus/Client.hs @@ -0,0 +1,65 @@ +{-# Language QuasiQuotes #-} + +module Fig.Bus.Client (Commands(..), busClient) where + +import Fig.Prelude + +import System.Exit (exitFailure) + +import qualified Control.Concurrent as Conc + +import Data.ByteString (hPut, hGetLine) + +import Fig.Utils.Net +import Fig.Utils.SExpr + +data Commands m = Commands + { ping :: m () + , subscribe :: SExpr -> m () + , publish :: SExpr -> [SExpr] -> m () + } + +newtype FigBusClientException = FigBusClientException Text + deriving (Show, Eq, Ord) +instance Exception FigBusClientException + +busClient :: forall m. + (MonadIO m, MonadThrow m, MonadMask m) => + (Text, Text) -> + (Commands IO -> IO ()) -> + (Commands IO -> SExpr -> IO ()) -> + IO () -> + m () +busClient loc@(host, port) onConn onData onQuit = catchFailure . client loc $ pure \h -> + let + sendSexpr x = liftIO . hPut h . encodeUtf8 $ pretty x <> "\n" + cmds = Commands + { ping = sendSexpr [sexp|(ping)|] + , subscribe = \ev -> sendSexpr [sexp|(sub ,ev)|] + , publish = \ev d -> sendSexpr [sexp|(pub ,ev ,@d)|] + } + in + ( do + liftIO . void . Conc.forkIO $ onConn cmds + forever do + line <- throwLeft id . decodeUtf8' =<< liftIO (hGetLine h) + case parseSExpr line of + Nothing -> throwM . FigBusClientException $ "Server sent malformed s-expression: " <> line + Just x -> liftIO $ onData cmds x + , liftIO onQuit + ) + where + catchFailure body = catch body \(e :: IOException) -> do + log $ "Failed to connect to bus at " <> host <> ":" <> port <> ": " <> tshow e + liftIO $ exitFailure + +_testClient :: IO () +_testClient = busClient ("localhost", "32050") + (\cmds -> do + cmds.subscribe [sexp|foo|] + forever do + Conc.threadDelay 1000000 + cmds.publish [sexp|bar|] [[sexp|42|]] + ) + (\_cmds d -> putStrLn $ "Received: " <> pretty d) + (pure ()) diff --git a/fig-monitor-bullfrog/fig-monitor-bullfrog.cabal b/fig-monitor-bullfrog/fig-monitor-bullfrog.cabal new file mode 100644 index 0000000..2d06268 --- /dev/null +++ b/fig-monitor-bullfrog/fig-monitor-bullfrog.cabal @@ -0,0 +1,55 @@ +cabal-version: 3.4 +name: fig-monitor-bullfrog +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , directory + , filepath + , http-types + , http-client + , http-client-tls + , megaparsec + , mtl + , network + , safe-exceptions + , scotty + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , warp + , websockets + , wuss + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Monitor.Bullfrog + Fig.Monitor.Bullfrog.Utils + +executable fig-monitor-bullfrog + import: defaults + import: deps + build-depends: fig-monitor-bullfrog, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs
\ No newline at end of file diff --git a/fig-monitor-bullfrog/main/Main.hs b/fig-monitor-bullfrog/main/Main.hs new file mode 100644 index 0000000..966e0a1 --- /dev/null +++ b/fig-monitor-bullfrog/main/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Monitor.Bullfrog +import Fig.Monitor.Bullfrog.Utils + +data Opts = Opts + { busHost :: Text + , busPort :: Text + , config :: FilePath + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") + <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + <*> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-monitor-bullfrog.toml") + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-monitor-bullfrog - monitor Bullfrog broadcast server" + ) + cfg <- loadConfig opts.config + bullfrogClient cfg (opts.busHost, opts.busPort) diff --git a/fig-monitor-bullfrog/src/Fig/Monitor/Bullfrog.hs b/fig-monitor-bullfrog/src/Fig/Monitor/Bullfrog.hs new file mode 100644 index 0000000..1a267f8 --- /dev/null +++ b/fig-monitor-bullfrog/src/Fig/Monitor/Bullfrog.hs @@ -0,0 +1,36 @@ +{-# Language QuasiQuotes #-} +{-# Language RecordWildCards #-} +{-# Language ApplicativeDo #-} + +module Fig.Monitor.Bullfrog + ( bullfrogClient + ) where + +import Fig.Prelude + +import qualified Data.Text as Text + +import qualified Wuss as WS +import qualified Network.WebSockets.Connection as WS + +import Fig.Utils.SExpr +import Fig.Bus.Client +import Fig.Monitor.Bullfrog.Utils + +bullfrogClient :: Config -> (Text, Text) -> IO () +bullfrogClient cfg busAddr = do + WS.runSecureClient "colonq.computer" 443 ("/bullfrog/api/channel/broadcast?token=" <> Text.unpack cfg.authToken) \conn -> do + busClient busAddr + (\cmds -> do + log "Connected to bus and broadcast server" + cmds.subscribe [sexp|(monitor bullfrog broadcast)|] + ) + (\_cmds d -> do + case d of + SExprList [ev, SExprString msg] + | ev == [sexp|(monitor bullfrog broadcast)|] -> do + log $ "Broadcasting message: " <> msg + WS.sendTextData conn msg + _ -> log $ "Invalid incoming message: " <> tshow d + ) + (pure ()) diff --git a/fig-monitor-bullfrog/src/Fig/Monitor/Bullfrog/Utils.hs b/fig-monitor-bullfrog/src/Fig/Monitor/Bullfrog/Utils.hs new file mode 100644 index 0000000..b0ae02b --- /dev/null +++ b/fig-monitor-bullfrog/src/Fig/Monitor/Bullfrog/Utils.hs @@ -0,0 +1,29 @@ +{-# Language ApplicativeDo #-} + +module Fig.Monitor.Bullfrog.Utils + ( FigMonitorBullfrogException(..) + , Config(..) + , loadConfig + ) where + +import Fig.Prelude + +import qualified Toml + +newtype FigMonitorBullfrogException = FigMonitorBullfrogException Text + deriving (Show, Eq, Ord) +instance Exception FigMonitorBullfrogException + +newtype Config = Config + { authToken :: Text + } deriving (Show, Eq, Ord) + +configCodec :: Toml.TomlCodec Config +configCodec = do + authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken) + pure $ Config{..} + +loadConfig :: FilePath -> IO Config +loadConfig path = Toml.decodeFileEither configCodec path >>= \case + Left err -> throwM . FigMonitorBullfrogException $ tshow err + Right config -> pure config diff --git a/fig-monitor-discord/fig-monitor-discord.cabal b/fig-monitor-discord/fig-monitor-discord.cabal new file mode 100644 index 0000000..ef74799 --- /dev/null +++ b/fig-monitor-discord/fig-monitor-discord.cabal @@ -0,0 +1,50 @@ +cabal-version: 3.4 +name: fig-monitor-discord +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , discord-haskell + , directory + , filepath + , megaparsec + , mtl + , network + , pcre-heavy + , safe-exceptions + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Monitor.Discord + Fig.Monitor.Discord.Utils + +executable fig-monitor-discord + import: defaults + import: deps + build-depends: fig-monitor-discord, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs
\ No newline at end of file diff --git a/fig-monitor-discord/main/Main.hs b/fig-monitor-discord/main/Main.hs new file mode 100644 index 0000000..595a270 --- /dev/null +++ b/fig-monitor-discord/main/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Monitor.Discord +import Fig.Monitor.Discord.Utils + +data Opts = Opts + { busHost :: Text + , busPort :: Text + , config :: FilePath + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") + <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + <*> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-monitor-discord.toml") + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-monitor-discord - monitor Discord chat events" + ) + cfg <- loadConfig opts.config + discordBot cfg (opts.busHost, opts.busPort) diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord.hs b/fig-monitor-discord/src/Fig/Monitor/Discord.hs new file mode 100644 index 0000000..ffba215 --- /dev/null +++ b/fig-monitor-discord/src/Fig/Monitor/Discord.hs @@ -0,0 +1,142 @@ +{-# Language QuasiQuotes #-} + +module Fig.Monitor.Discord where + +import Fig.Prelude + +import GHC.Real (fromIntegral) + +import Control.Arrow ((>>>)) +import Control.Monad (unless) +import Control.Monad.Reader (runReaderT) +import Control.Concurrent (forkIO) +import qualified Control.Concurrent.Chan as Chan + +import qualified Data.Text as Text +import qualified Data.ByteString.Base64 as BS.Base64 +import qualified Data.Map.Strict as Map + +import qualified Text.Regex.PCRE.Heavy as PCRE + +import qualified Discord as Dis +import qualified Discord.Types as Dis +import qualified Discord.Requests as Dis +import qualified Discord.Interactions as Dis + +import Fig.Utils.SExpr +import Fig.Bus.Client +import Fig.Monitor.Discord.Utils + +data OutgoingMessage = OutgoingMessage + { user :: Text + , msg :: Text + } + +discordBot :: Config -> (Text, Text) -> IO () +discordBot cfg busAddr = do + outgoing <- Chan.newChan @OutgoingMessage + let cid = Dis.DiscordId $ fromIntegral cfg.channel + busClient busAddr + (\cmds -> do + cmds.subscribe [sexp|(monitor discord chat outgoing)|] + err <- Dis.runDiscord Dis.def + { Dis.discordToken = cfg.authToken + , Dis.discordOnStart = do + let activity = Dis.def + { Dis.activityName = "LCOLONQ" + , Dis.activityType = Dis.ActivityTypeCompeting + } + let opts = Dis.UpdateStatusOpts + { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = Dis.UpdateStatusOnline + , updateStatusOptsAFK = False + } + Dis.sendCommand (Dis.UpdateStatus opts) + dst <- ask + liftIO . void . forkIO . forever $ flip runReaderT dst do + o <- liftIO $ Chan.readChan outgoing + void . Dis.restCall . Dis.CreateMessage cid $ mconcat + [ "`<", o.user, ">` " + , o.msg + ] + , Dis.discordOnLog = log + , Dis.discordOnEvent = \case + Dis.Ready _ _ _ _ _ _ (Dis.PartialApplication i _) -> do + cmd <- case Dis.createUser "ping" of + Nothing -> throwM $ FigMonitorDiscordException "Failed to create ping command" + Just cmd -> pure cmd + log "Creating application command" + resp <- Dis.restCall $ Dis.CreateGlobalApplicationCommand i cmd + log $ tshow resp + Dis.InteractionCreate cmd@Dis.InteractionApplicationCommand{} -> do + void . Dis.restCall . Dis.CreateInteractionResponse (Dis.interactionId cmd) (Dis.interactionToken cmd) $ Dis.interactionResponseBasic "pong" + Dis.MessageCreate m -> + let + auth = Dis.messageAuthor m + mmemb = Dis.messageMember m + name = fromMaybe (Dis.userName auth) (Dis.memberNick =<< mmemb) + attach = Dis.attachmentProxy <$> Dis.messageAttachments m + reply = Dis.messageReferencedMessage m + mentions = Map.fromList + . filter (isJust . snd) + $ (\u -> (Dis.userId u, Dis.memberNick <$> Dis.userMember u)) + <$> Dis.messageMentions m + replyNick = join . join $ flip Map.lookup mentions . Dis.userId . Dis.messageAuthor =<< reply + replyUser = if isJust replyNick then replyNick else Dis.userName . Dis.messageAuthor <$> reply + msg = Dis.messageContent m + replyMsg = Dis.messageContent <$> reply + replyStr = replyUser >>= \ru -> + if ru == "The Computer" + then replyMsg >>= ( + PCRE.scan [PCRE.re|^`\<(.*)\>`|] >>> \case + ((_, [compName]):_) -> Just compName + _ -> Just ru + ) + else Just ru + msgReplacedEmotes = PCRE.gsub + [PCRE.re|<:([\w_-]+):(\d+)>|] + (\(_ :: Text) -> \case + ([emotename, _num] :: [Text]) -> case emotename of + "mrgreen" -> "🟢" + "mrred" -> "🔴" + "mrblue" -> "🔵" + _ -> ":" <> emotename <> ":" + -- "https://cdn.discordapp.com/emojis/" <> num <> ".webp" + _ -> "<unknown emote>" + ) + msg + in unless (Dis.userIsBot auth) do + log $ "Received: " <> msg <> " (from " <> name <> ")" + liftIO $ cmds.publish [sexp|(monitor discord chat incoming)|] + [ SExprString . BS.Base64.encodeBase64 $ encodeUtf8 name + , SExprList [] + , SExprString . BS.Base64.encodeBase64 . encodeUtf8 . Text.intercalate " " + $ maybe [] ((:[]) . (<>":")) replyStr <> + [ msgReplacedEmotes + , Text.intercalate " " + $ Text.takeWhile (/='?') + <$> attach + ] + ] + _ -> pure () + } + log err + ) + (\_cmds d -> do + case d of + SExprList [ev, SExprString euser, SExprString emsg] + | ev == [sexp|(monitor discord chat outgoing)|] + , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser) + , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do + log $ "Sending: " <> msg <> " (from " <> user <> ")" + let replacements :: [(Text, Text)] = + [ (":mrgreen:", "<:mrgreen:1093634800792911972>") + , (":mrblue:", "<:mrblue:1154526193358491719>") + , (":mrred:", "<:mrred:1154524307649724449>") + ] + let newMsg = foldr' (\(n, r) h -> Text.replace n r h) msg replacements + Chan.writeChan outgoing OutgoingMessage { user = user, msg = newMsg } + _ -> log $ "Invalid outgoing message: " <> tshow d + ) + (pure ()) diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs b/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs new file mode 100644 index 0000000..b2a316d --- /dev/null +++ b/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs @@ -0,0 +1,31 @@ +{-# Language ApplicativeDo #-} + +module Fig.Monitor.Discord.Utils + ( FigMonitorDiscordException(..) + , Config(..) + , loadConfig + ) where + +import Fig.Prelude + +import qualified Toml + +newtype FigMonitorDiscordException = FigMonitorDiscordException Text + deriving (Show, Eq, Ord) +instance Exception FigMonitorDiscordException + +data Config = Config + { authToken :: Text + , channel :: Int + } deriving (Show, Eq, Ord) + +configCodec :: Toml.TomlCodec Config +configCodec = do + authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken) + channel <- Toml.int "channel" Toml..= (\a -> a.channel) + pure $ Config{..} + +loadConfig :: FilePath -> IO Config +loadConfig path = Toml.decodeFileEither configCodec path >>= \case + Left err -> throwM . FigMonitorDiscordException $ tshow err + Right config -> pure config diff --git a/fig-monitor-irc/fig-monitor-irc.cabal b/fig-monitor-irc/fig-monitor-irc.cabal new file mode 100644 index 0000000..618b63b --- /dev/null +++ b/fig-monitor-irc/fig-monitor-irc.cabal @@ -0,0 +1,50 @@ +cabal-version: 3.4 +name: fig-monitor-irc +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , directory + , filepath + , irc-client + , megaparsec + , microlens + , mtl + , network + , safe-exceptions + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Monitor.IRC + Fig.Monitor.IRC.Utils + +executable fig-monitor-irc + import: defaults + import: deps + build-depends: fig-monitor-irc, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs
\ No newline at end of file diff --git a/fig-monitor-irc/main/Main.hs b/fig-monitor-irc/main/Main.hs new file mode 100644 index 0000000..c28061b --- /dev/null +++ b/fig-monitor-irc/main/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Monitor.IRC +import Fig.Monitor.IRC.Utils + +data Opts = Opts + { busHost :: Text + , busPort :: Text + , config :: FilePath + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") + <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + <*> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-monitor-irc.toml") + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-monitor-discord - monitor IRC chat events" + ) + cfg <- loadConfig opts.config + ircBot cfg (opts.busHost, opts.busPort) diff --git a/fig-monitor-irc/src/Fig/Monitor/IRC.hs b/fig-monitor-irc/src/Fig/Monitor/IRC.hs new file mode 100644 index 0000000..55d17e5 --- /dev/null +++ b/fig-monitor-irc/src/Fig/Monitor/IRC.hs @@ -0,0 +1,83 @@ +{-# Language QuasiQuotes #-} + +module Fig.Monitor.IRC where + +import Fig.Prelude + +import qualified Data.Text as Text +import qualified Data.ByteString.Base64 as BS.Base64 + +import Lens.Micro ((%~), (.~), (^.)) + +import qualified Control.Concurrent as Conc +import qualified Control.Concurrent.Chan as Chan + +import qualified Network.IRC.Client as IRC + +import Fig.Utils.SExpr +import Fig.Bus.Client +import Fig.Monitor.IRC.Utils + +data OutgoingMessage = OutgoingMessage + { user :: Text + , msg :: Text + } + +srcUser :: IRC.Source a -> Maybe a +srcUser (IRC.Channel _ user) = Just user +srcUser (IRC.User user) = Just user +srcUser _ = Nothing + +ircBot :: Config -> (Text, Text) -> IO () +ircBot cfg busAddr = do + outgoing <- Chan.newChan @OutgoingMessage + mircst <- Conc.newEmptyMVar + void . Conc.forkIO $ Conc.readMVar mircst >>= \ircst -> forever $ do + o <- liftIO $ Chan.readChan outgoing + log $ "Sending: " <> o.msg <> " (from " <> o.user <> ")" + let msg = IRC.Privmsg cfg.sendchannel . Right . Text.take 400 $ mconcat + [ "<", o.user, "> " + , Text.replace "\n" " " o.msg + ] + IRC.runIRCAction (IRC.send msg) ircst + busClient busAddr + (\cmds -> do + cmds.subscribe [sexp|(monitor irc chat outgoing)|] + let handler = IRC.EventHandler + ( \case + ev + | IRC.Privmsg _ (Right msg) <- ev ^. IRC.message -> Just msg + | otherwise -> Nothing + ) + ( \src msg -> case srcUser src of + Just user -> do + log $ "Received: " <> msg <> " (from " <> user <> ")" + liftIO $ cmds.publish [sexp|(monitor irc chat incoming)|] + [ SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ user + , SExprList [] + , SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ msg + ] + Nothing -> pure () + ) + ircst <- IRC.newIRCState + ( IRC.tlsConnection (IRC.WithDefaultConfig (encodeUtf8 cfg.host) cfg.port) + -- ( IRC.plainConnection (encodeUtf8 cfg.host) cfg.port + ) + ( IRC.defaultInstanceConfig cfg.nick + & IRC.handlers %~ (handler:) + & IRC.channels .~ cfg.channels + ) + () + Conc.putMVar mircst ircst + IRC.runClientWith ircst + ) + (\_cmds d -> do + case d of + SExprList [ev, SExprString euser, SExprString emsg] + | ev == [sexp|(monitor irc chat outgoing)|] + , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser) + , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do + Chan.writeChan outgoing OutgoingMessage { user = user, msg = msg } + _ -> log $ "Invalid outgoing message: " <> tshow d + ) + (pure ()) diff --git a/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs b/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs new file mode 100644 index 0000000..2cf46b1 --- /dev/null +++ b/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs @@ -0,0 +1,37 @@ +{-# Language ApplicativeDo #-} + +module Fig.Monitor.IRC.Utils + ( FigMonitorIRCException(..) + , Config(..) + , loadConfig + ) where + +import Fig.Prelude + +import qualified Toml + +newtype FigMonitorIRCException = FigMonitorIRCException Text + deriving (Show, Eq, Ord) +instance Exception FigMonitorIRCException + +data Config = Config + { host :: Text + , port :: Int + , nick :: Text + , sendchannel :: Text + , channels :: [Text] + } deriving (Show, Eq, Ord) + +configCodec :: Toml.TomlCodec Config +configCodec = do + host <- Toml.text "host" Toml..= (\a -> a.host) + port <- Toml.int "port" Toml..= (\a -> a.port) + nick <- Toml.text "nick" Toml..= (\a -> a.nick) + sendchannel <- Toml.text "sendchannel" Toml..= (\a -> a.sendchannel) + channels <- Toml.arrayOf Toml._Text "channels" Toml..= (\a -> a.channels) + pure $ Config{..} + +loadConfig :: FilePath -> IO Config +loadConfig path = Toml.decodeFileEither configCodec path >>= \case + Left err -> throwM . FigMonitorIRCException $ tshow err + Right config -> pure config diff --git a/fig-monitor-twitch/fig-monitor-twitch.cabal b/fig-monitor-twitch/fig-monitor-twitch.cabal new file mode 100644 index 0000000..b177d32 --- /dev/null +++ b/fig-monitor-twitch/fig-monitor-twitch.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.4 +name: fig-monitor-twitch +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , base64 + , binary + , bytestring + , containers + , data-default-class + , directory + , filepath + , http-types + , http-client + , http-client-tls + , megaparsec + , mtl + , network + , safe-exceptions + , scotty + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , warp + , websockets + , wuss + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Monitor.Twitch + Fig.Monitor.Twitch.Utils + -- Fig.Monitor.Twitch.Chat + -- Fig.Monitor.Twitch.EventSub + -- Fig.Monitor.Twitch.UserTokenRedirectServer + +executable fig-monitor-twitch + import: defaults + import: deps + build-depends: fig-monitor-twitch, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs
\ No newline at end of file diff --git a/fig-monitor-twitch/main/Main.hs b/fig-monitor-twitch/main/Main.hs new file mode 100644 index 0000000..2232a03 --- /dev/null +++ b/fig-monitor-twitch/main/Main.hs @@ -0,0 +1,45 @@ +module Main where + +import Fig.Prelude + +import Options.Applicative + +import Fig.Monitor.Twitch +import Fig.Monitor.Twitch.Utils + +data Command + = Monitor + | Chatbot + | RedirectServer + +parseCommand :: Parser Command +parseCommand = subparser $ mconcat + [ command "monitor" $ info (pure Monitor) (progDesc "Launch the Twitch monitor") + , command "chatbot" $ info (pure Chatbot) (progDesc "Launch the Twitch chatbot") + , command "user-token-server" $ info (pure RedirectServer) (progDesc "Launch a web server to handle authentication redirects") + ] +data Opts = Opts + { busHost :: Text + , busPort :: Text + , config :: FilePath + , command :: Command + } + +parseOpts :: Parser Opts +parseOpts = Opts + <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") + <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + <*> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-monitor-twitch.toml") + <*> parseCommand + +main :: IO () +main = do + opts <- execParser $ info (parseOpts <**> helper) + ( fullDesc + <> header "fig-monitor-twitch - monitor Twitch.tv stream events" + ) + cfg <- loadConfig opts.config + case opts.command of + Monitor -> twitchEventClient cfg (opts.busHost, opts.busPort) + Chatbot -> twitchChatClient cfg (opts.busHost, opts.busPort) + RedirectServer -> userTokenRedirectServer cfg diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs new file mode 100644 index 0000000..360e9c8 --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs @@ -0,0 +1,530 @@ +{-# Language QuasiQuotes #-} +{-# Language RecordWildCards #-} +{-# Language ApplicativeDo #-} + +module Fig.Monitor.Twitch + ( twitchEventClient + , twitchChatClient + , userTokenRedirectServer + ) where + +import Fig.Prelude + +import Control.Monad (unless) + +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.ByteString.Base64 as BS.Base64 +import qualified Data.Vector as V +import qualified Data.Map.Strict as Map + +import Data.Default.Class (def) + +import Data.Aeson ((.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Wuss as WS +import qualified Network.WebSockets.Connection as WS + +import Network.Wai.Handler.Warp (setPort) +import qualified Web.Scotty as Scotty + +import Network.HTTP.Client as HTTP +import Network.HTTP.Types.Status as HTTP + +import Fig.Utils.SExpr +import Fig.Bus.Client +import Fig.Monitor.Twitch.Utils + +loginToMaybeUserId :: Text -> Authed (Maybe Text) +loginToMaybeUserId login = do + res <- authedRequestJSON "GET" ("https://api.twitch.tv/helix/users?login=" <> login) () + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _ -> mempty + pure mid + +loginToUserId :: Text -> Authed Text +loginToUserId login = do + res <- authedRequestJSON "GET" ("https://api.twitch.tv/helix/users?login=" <> login) () + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _ -> mempty + maybe (throwM $ FigMonitorTwitchException "Failed to extract user ID") pure mid + +subscribe :: Text -> Text -> Text -> Authed () +subscribe sessionId event user = do + log $ "Subscribing to " <> event <> " events for user ID: " <> user + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" $ Aeson.object + [ "type" .= event + , "version" .= ("1" :: Text) + , "condition" .= Aeson.object + [ "broadcaster_user_id" .= user + ] + , "transport" .= Aeson.object + [ "method" .= ("websocket" :: Text) + , "session_id" .= sessionId + ] + ] + case Aeson.parseMaybe (.: "total_cost") res of + Just (_ :: Int) -> pure () + _ -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" + +subscribeFollows :: Text -> Text -> Authed () +subscribeFollows sessionId user = do + log $ "Subscribing to channel.follow events for user ID: " <> user + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" $ Aeson.object + [ "type" .= ("channel.follow" :: Text) + , "version" .= ("2" :: Text) + , "condition" .= Aeson.object + [ "broadcaster_user_id" .= user + , "moderator_user_id" .= user + ] + , "transport" .= Aeson.object + [ "method" .= ("websocket" :: Text) + , "session_id" .= sessionId + ] + ] + case Aeson.parseMaybe (.: "total_cost") res of + Just (_ :: Int) -> pure () + _ -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" + +subscribeRaids :: Text -> Text -> Authed () +subscribeRaids sessionId user = do + log $ "Subscribing to channel.raid events for user ID: " <> user + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" $ Aeson.object + [ "type" .= ("channel.raid" :: Text) + , "version" .= ("1" :: Text) + , "condition" .= Aeson.object + [ "to_broadcaster_user_id" .= user + ] + , "transport" .= Aeson.object + [ "method" .= ("websocket" :: Text) + , "session_id" .= sessionId + ] + ] + case Aeson.parseMaybe (.: "total_cost") res of + Just (_ :: Int) -> pure () + _ -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" + +poll :: Text -> [Text] -> Text -> Authed () +poll title choices user = do + log $ "Starting a new poll: \"" <> title <> "\"" + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/polls" $ Aeson.object + [ "broadcaster_id" .= user + , "title" .= title + , "choices" .= ((\c -> Aeson.object ["title" .= c]) <$> choices) + , "channel_points_voting_enabled" .= True + , "channel_points_per_vote" .= (1000 :: Integer) + , "duration" .= (60 :: Integer) + ] + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _ -> mempty + case mid of + Just (_ :: Text) -> pure () + Nothing -> do + log "Failed to start poll" + log $ tshow res + +createPrediction :: Text -> [Text] -> Text -> Authed () +createPrediction title choices user = do + log $ "Starting a new prediction: \"" <> title <> "\"" + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/predictions" $ Aeson.object + [ "broadcaster_id" .= user + , "title" .= title + , "outcomes" .= ((\c -> Aeson.object ["title" .= c]) <$> choices) + , "prediction_window" .= (120 :: Integer) + ] + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _ -> mempty + case mid of + Just (_ :: Text) -> pure () + Nothing -> log "Failed to start prediction" + +finishPrediction :: Text -> Text -> Text -> Authed () +finishPrediction pid oid user = do + log $ "Ending prediction: \"" <> pid <> "\"" + res <- authedRequestJSON "PATCH" "https://api.twitch.tv/helix/predictions" $ Aeson.object + [ "broadcaster_id" .= user + , "id" .= pid + , "status" .= ("RESOLVED" :: Text) + , "winning_outcome_id" .= oid + ] + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _ -> mempty + case mid of + Just (_ :: Text) -> pure () + Nothing -> log "Failed to end prediction" + +addVIP :: Text -> Text -> Authed () +addVIP vipuser user = do + log $ "Adding VIP user: \"" <> vipuser <> "\"" + let body = Aeson.encode $ Aeson.object + [ "broadcaster_id" .= user + , "user_id" .= vipuser + ] + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/channels/vips" + let request = initialRequest + { method = encodeUtf8 "POST" + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do + log $ "Failed to add VIP: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) + +removeVIP :: Text -> Text -> Authed () +removeVIP vipuser user = do + log $ "Removing VIP user: \"" <> vipuser <> "\"" + let body = Aeson.encode $ Aeson.object + [ "broadcaster_id" .= user + , "user_id" .= vipuser + ] + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/channels/vips" + let request = initialRequest + { method = encodeUtf8 "DELETE" + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do + log $ "Failed to remove VIP: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) + +twitchEventClient :: Config -> (Text, Text) -> IO () +twitchEventClient cfg busAddr = do + WS.runSecureClient "eventsub.wss.twitch.tv" 443 "/ws" \conn -> do + welcomeStr <- WS.receiveData conn + (sessionId :: Text) <- case Aeson.eitherDecodeStrict welcomeStr of + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right res -> do + let mid = flip Aeson.parseMaybe res \obj -> do + payload <- obj .: "payload" + session <- payload .: "session" + session .: "id" + maybe (throwM $ FigMonitorTwitchException "Failed to extract session ID") pure mid + log $ "Connected to Twitch API, session ID is: " <> sessionId + runAuthed cfg do + user <- loginToUserId cfg.userLogin + subscribe sessionId "channel.channel_points_custom_reward_redemption.add" user + subscribe sessionId "channel.prediction.begin" user + subscribe sessionId "channel.prediction.end" user + subscribe sessionId "channel.poll.begin" user + subscribe sessionId "channel.poll.end" user + subscribe sessionId "channel.subscribe" user + subscribe sessionId "channel.subscription.gift" user + subscribeFollows sessionId user + subscribeRaids sessionId user + busClient busAddr + (\cmds -> do + cmds.subscribe [sexp|(monitor twitch poll create)|] + cmds.subscribe [sexp|(monitor twitch prediction create)|] + cmds.subscribe [sexp|(monitor twitch prediction finish)|] + cmds.subscribe [sexp|(monitor twitch vip add)|] + cmds.subscribe [sexp|(monitor twitch vip remove)|] + forever do + resp <- WS.receiveData conn + case Aeson.eitherDecodeStrict resp of + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right res -> case Aeson.parseMaybe ((.: "metadata") >=> (.: "message_type")) res of + Just ("notification" :: Text) -> case Aeson.parseMaybe ((.: "metadata") >=> (.: "subscription_type")) res of + Just ("channel.channel_points_custom_reward_redemption.add" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + nm <- event .: "user_name" + reward <- event .: "reward" + title <- reward .: "title" + minput <- event .:? "user_input" + pure (nm, title, minput) + case Aeson.parseMaybe parseEvent res of + Just (nm, title, minput) -> do + log $ "Channel point reward \"" <> title <> "\" redeemed by: " <> nm + cmds.publish [sexp|(monitor twitch redeem incoming)|] + $ [SExprString nm, SExprString title] <> maybe [] ((:[]) . SExprString . BS.Base64.encodeBase64 . encodeUtf8) minput + _ -> log "Failed to extract payload from channel point redeem event" + Just ("channel.prediction.begin" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + pid <- event .: "id" + oids <- event .: "outcomes" >>= \case + Aeson.Array os -> forM os $ \case + Aeson.Object out -> (,) <$> (out .: "title") <*> (out .: "id") + _ -> mempty + _ -> mempty + pure (pid, oids) + case Aeson.parseMaybe parseEvent res of + Just (pid, oids) -> do + log $ "Prediction begin: " <> pid + cmds.publish [sexp|(monitor twitch prediction begin)|] + [ SExprString pid + , SExprList $ (\(title, oid) -> SExprList [SExprString title, SExprString oid]) <$> toList oids + ] + _ -> log "Failed to extract ID from payload for prediction begin event" + Just ("channel.prediction.end" :: Text) -> do + log "Prediction end" + cmds.publish [sexp|(monitor twitch prediction end)|] [] + Just ("channel.raid" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "from_broadcaster_user_name" + case Aeson.parseMaybe parseEvent res of + Just nm -> do + log $ "Incoming raid from: " <> nm + cmds.publish [sexp|(monitor twitch raid)|] [SExprString nm] + _ -> log "Failed to extract user from raid event" + Just ("channel.follow" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "user_name" + case Aeson.parseMaybe parseEvent res of + Just nm -> do + log $ "New follower: " <> nm + cmds.publish [sexp|(monitor twitch follow)|] [SExprString nm] + _ -> log "Failed to extract user from follow event" + Just ("channel.subscribe" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "user_name" + case Aeson.parseMaybe parseEvent res of + Just nm -> do + log $ "New subscriber: " <> nm + cmds.publish [sexp|(monitor twitch subscribe)|] [SExprString nm] + _ -> log "Failed to extract user from subscribe event" + Just ("channel.cheer" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + nm <- event .: "user_name" + bits <- event .: "bits" + pure (nm, bits) + case Aeson.parseMaybe parseEvent res of + Just (nm, bits) -> do + log $ "New cheer: " <> nm <> " " <> tshow bits + cmds.publish [sexp|(monitor twitch cheer)|] [SExprString nm, SExprInteger bits] + _ -> log "Failed to extract user from cheer event" + Just ("channel.subscription.gift" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + nm <- event .: "user_name" + num <- event .: "total" + pure (nm, num) + case Aeson.parseMaybe parseEvent res of + Just (nm, num) -> do + log $ "User " <> nm <> " gifted subs: " <> tshow num + cmds.publish [sexp|(monitor twitch gift)|] [SExprString nm, SExprInteger num] + _ -> log "Failed to extract user from gift sub event" + Just ("channel.poll.begin" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "id" + case Aeson.parseMaybe parseEvent res of + Just pollid -> do + log $ "Poll begin: " <> pollid + cmds.publish [sexp|(monitor twitch poll begin)|] [SExprString pollid] + _ -> log "Failed to extract ID from payload for poll begin event" + Just ("channel.poll.end" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + pollid <- event .: "id" + event .: "choices" >>= \case + Aeson.Array cs -> do + choices <- forM cs \case + Aeson.Object c -> do + t <- c .: "title" + v <- c .: "votes" + pure (t, v) + _ -> mempty + pure (pollid, toList choices) + _ -> mempty + case Aeson.parseMaybe parseEvent res of + Just (pollid, choices) -> do + let schoices = (\(t, v) -> SExprList [SExprString t, SExprInteger v]) <$> choices + log $ "Poll end: " <> pollid + cmds.publish [sexp|(monitor twitch poll end)|] [SExprString pollid, SExprList schoices] + _ -> log "Failed to extract ID from payload for poll end event" + _ -> log $ "Received unknown notification event: " <> tshow resp + Just "session_keepalive" -> pure () + _ -> log $ "Received unknown response: " <> tshow resp + ) + (\_cmds d -> do + case d of + SExprList [ev, SExprString title, SExprList schoices] + | ev == [sexp|(monitor twitch poll create)|] -> do + let choices = Maybe.mapMaybe (\case SExprString c -> Just c; _ -> Nothing) schoices + runAuthed cfg do + user <- loginToUserId cfg.userLogin + poll title choices user + | ev == [sexp|(monitor twitch prediction create)|] -> do + let choices = Maybe.mapMaybe (\case SExprString c -> Just c; _ -> Nothing) schoices + runAuthed cfg do + user <- loginToUserId cfg.userLogin + createPrediction title choices user + SExprList [ev, SExprString pid, SExprString oid] + | ev == [sexp|(monitor twitch prediction finish)|] -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + finishPrediction pid oid user + SExprList [ev, SExprString u] + | ev == [sexp|(monitor twitch vip add)|] -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + loginToMaybeUserId u >>= \case + Nothing -> pure () + Just vipuser -> addVIP vipuser user + | ev == [sexp|(monitor twitch vip remove)|] -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + loginToMaybeUserId u >>= \case + Nothing -> pure () + Just vipuser -> removeVIP vipuser user + _ -> log $ "Invalid incoming message: " <> tshow d + ) + (pure ()) + +data IRCMessage = IRCMessage + { tags :: Map.Map Text Text + , prefix :: Maybe Text + , command :: Text + , params :: [Text] + } deriving (Show, Eq, Ord) + +parseIRCMessage :: Text -> IRCMessage +parseIRCMessage (Text.strip -> fullrest) = + let + (tags, tagsrest) = + if Text.head fullrest == '@' + then + let (tstr, rest) = Text.breakOn " " fullrest + in ( Map.fromList $ second (Text.drop 1) . Text.breakOn "=" <$> Text.splitOn ";" (Text.drop 1 tstr) + , Text.strip rest + ) + else (Map.empty, fullrest) + (prefix, prefixrest) = + if Text.head tagsrest == ':' + then + let (pstr, rest) = Text.breakOn " " tagsrest + in ( Just $ Text.drop 1 pstr + , Text.strip rest + ) + else (Nothing, tagsrest) + (command, cmdrest) = Text.breakOn " " prefixrest + params = case Text.breakOn ":" $ Text.strip cmdrest of + (Text.strip -> "", rest) -> [rest] + (ps, rest) -> Text.splitOn " " (Text.strip ps) <> [Text.drop 1 rest] + in IRCMessage{..} + +twitchChatClient :: Config -> (Text, Text) -> IO () +twitchChatClient cfg busAddr = do + log "Starting chatbot" + WS.runSecureClient "irc-ws.chat.twitch.tv" 443 "/" \conn -> do + WS.sendTextData conn $ "PASS oauth:" <> cfg.userToken + WS.sendTextData conn ("NICK lcolonq" :: Text) + WS.sendTextData conn ("CAP REQ :twitch.tv/commands twitch.tv/tags" :: Text) + WS.sendTextData conn $ "JOIN #" <> cfg.monitorChat + -- WS.sendTextData conn ("PRIVMSG #lcolonq :test the other direction" :: Text) + busClient busAddr + (\cmds -> do + cmds.subscribe [sexp|(monitor twitch chat outgoing)|] + forever do + resp <- WS.receiveData conn + forM (Text.lines resp) $ \line -> do + let msg = parseIRCMessage line + case msg.command of + "PING" -> do + log "Received PING, sending PONG" + WS.sendTextData conn $ "PONG :" <> mconcat msg.params + "CLEARCHAT" -> do + log "Received CLEARCHAT" + cmds.publish [sexp|(monitor twitch chat clear-chat)|] $ SExprString <$> msg.params + "NOTICE" -> do + log "Received NOTICE" + cmds.publish [sexp|(monitor twitch chat notice)|] $ SExprString <$> msg.params + "USERNOTICE" -> do + log "Received USERNOTICE" + cmds.publish [sexp|(monitor twitch chat user-notice)|] $ SExprString <$> msg.params + "PRIVMSG" + | Just displaynm <- Map.lookup "display-name" msg.tags + , Nothing <- Map.lookup "custom-reward-id" msg.tags -> do + cmds.publish [sexp|(monitor twitch chat incoming)|] + [ SExprString . BS.Base64.encodeBase64 $ encodeUtf8 displaynm + , SExprList $ (\(key, v) -> SExprList [SExprString key, SExprString v]) <$> Map.toList msg.tags + , SExprString . BS.Base64.encodeBase64 . encodeUtf8 . Text.unwords $ drop 1 msg.params + ] + _ -> pure () + ) + (\_cmds d -> do + case d of + SExprList [ev, SExprString msg] | ev == [sexp|(monitor twitch chat outgoing)|] -> do + log $ "Sending: " <> msg + WS.sendTextData conn $ mconcat + [ "PRIVMSG #" + , cfg.monitorChat + , " :" + , msg + ] + _ -> log $ "Invalid outgoing message: " <> tshow d + ) + (pure ()) + +userTokenRedirectServer :: Config -> IO () +userTokenRedirectServer cfg = do + log "Starting token redirect server on port 4444" + Scotty.scottyOpts opts do + Scotty.get "/" do + Scotty.html $ mconcat + [ "<a href=\"https://id.twitch.tv/oauth2/authorize?response_type=token" + , "&client_id=", Text.Lazy.fromStrict cfg.clientId + , "&redirect_uri=http://localhost:4444" + , "&scope=", Text.Lazy.replace ":" "%3A" $ Text.Lazy.intercalate "+" scopes + , "\">Authenticate</a>" + ] + where + opts = Scotty.Options + { Scotty.verbose = 0 + , Scotty.settings = setPort 4444 (Scotty.settings def) + } + scopes = + [ "channel:manage:polls" + , "channel:manage:predictions" + , "channel:manage:redemptions" + , "channel:manage:vips" + , "channel:read:polls" + , "channel:read:predictions" + , "channel:read:redemptions" + , "channel:read:subscriptions" + , "channel:read:vips" + , "channel:moderate" + , "moderator:read:followers" + , "moderator:read:chatters" + , "moderator:manage:shoutouts" + , "chat:edit" + , "chat:read" + , "bits:read" + ] diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs new file mode 100644 index 0000000..f1d757c --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs @@ -0,0 +1,87 @@ +{-# Language RecordWildCards #-} +{-# Language ApplicativeDo #-} + +module Fig.Monitor.Twitch.Utils + ( FigMonitorTwitchException(..) + , loadConfig + , RequestConfig(..) + , Config(..) + , authedRequest + , authedRequestJSON + , Authed + , runAuthed + ) where + +import Fig.Prelude + +import Control.Monad.Reader (ReaderT, runReaderT) + +import qualified Data.ByteString.Lazy as BS.Lazy + +import qualified Toml + +import qualified Data.Aeson as Aeson + +import Network.HTTP.Client as HTTP +import Network.HTTP.Client.TLS as HTTP + +newtype FigMonitorTwitchException = FigMonitorTwitchException Text + deriving (Show, Eq, Ord) +instance Exception FigMonitorTwitchException + +data Config = Config + { clientId :: Text + , userToken :: Text + , userLogin :: Text + , monitorChat :: Text + } deriving (Show, Eq, Ord) + +configCodec :: Toml.TomlCodec Config +configCodec = do + clientId <- Toml.text "client_id" Toml..= (\a -> a.clientId) + userToken <- Toml.text "user_token" Toml..= (\a -> a.userToken) + -- userIds <- Toml.arrayOf Toml._Text "user_ids" Toml..= (\a -> a.userIds) + userLogin <- Toml.text "user_login" Toml..= (\a -> a.userLogin) + monitorChat <- Toml.text "monitor_chat" Toml..= (\a -> a.monitorChat) + pure $ Config{..} + +loadConfig :: FilePath -> IO Config +loadConfig path = Toml.decodeFileEither configCodec path >>= \case + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right config -> pure config + +data RequestConfig = RequestConfig + { config :: Config + , manager :: HTTP.Manager + } + +newtype Authed a = Authed { unAuthed :: ReaderT RequestConfig IO a } + deriving (Functor, Applicative, Monad, MonadReader RequestConfig, MonadIO, MonadThrow) + +authedRequest :: Text -> Text -> BS.Lazy.ByteString -> Authed BS.Lazy.ByteString +authedRequest method url body = do + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack url + let request = initialRequest + { method = encodeUtf8 method + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + pure $ HTTP.responseBody response + +authedRequestJSON :: (Aeson.ToJSON a, Aeson.FromJSON b) => Text -> Text -> a -> Authed b +authedRequestJSON method url val = do + resp <- authedRequest method url $ Aeson.encode val + case Aeson.eitherDecode resp of + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right res -> pure res + +runAuthed :: Config -> Authed a -> IO a +runAuthed config body = do + manager <- HTTP.newManager HTTP.tlsManagerSettings + runReaderT body.unAuthed RequestConfig{..} diff --git a/fig-utils/fig-utils.cabal b/fig-utils/fig-utils.cabal new file mode 100644 index 0000000..9bb115d --- /dev/null +++ b/fig-utils/fig-utils.cabal @@ -0,0 +1,36 @@ +cabal-version: 3.4 +name: fig-utils +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +library + import: defaults + hs-source-dirs: src + exposed-modules: + Fig.Prelude + Fig.Utils + Fig.Utils.Net + Fig.Utils.SExpr + build-depends: + base + , binary + , bytestring + , containers + , directory + , containers + , directory + , filepath + , megaparsec + , mtl + , network + , safe-exceptions + , template-haskell + , text + , time + , transformers + , unordered-containers + , vector diff --git a/fig-utils/src/Fig/Prelude.hs b/fig-utils/src/Fig/Prelude.hs new file mode 100644 index 0000000..ceddba0 --- /dev/null +++ b/fig-utils/src/Fig/Prelude.hs @@ -0,0 +1,119 @@ +module Fig.Prelude + ( quot, mod, rem, quotRem + , module GHC.Num + , module GHC.Float + + , module System.IO + , module System.FilePath.Posix + + , module Data.Kind + , module Data.Void + , module Data.Bool + , module Data.Char + , module Data.Int + , module Data.Text + , module Data.Text.IO + , module Data.Text.Encoding + , module Data.ByteString + , module Data.Tuple + , module Data.Maybe + , module Data.Either + , module Data.List + , module Data.Function + , module Data.Eq + , module Data.Ord + , module Data.Semigroup + , module Data.Monoid + , module Data.Functor + , module Data.Bifunctor + , module Data.Traversable + , module Data.Foldable + + , module Text.Show + , module Text.Read + + , module Control.Applicative + , module Control.Monad + , module Control.Monad.IO.Class + , module Control.Monad.State.Class + , module Control.Monad.Reader.Class + , module Control.Exception.Safe + + , tshow + , headMay, atMay + , throwLeft + , log + + , Pretty(..) + ) where + +import Prelude (quot, mod, rem, quotRem) + +import GHC.Num (Num(..), Integer) +import GHC.Float (Double) + +import System.IO (IO, stdin, stdout, stderr, FilePath, Handle) +import System.FilePath.Posix ((</>)) + +import Data.Kind (Type) +import Data.Void (Void) +import Data.Bool (Bool(..), otherwise, not, (&&), (||)) +import Data.Char (Char, isUpper) +import Data.Int (Int) +import Data.Text (Text, pack, unpack, unwords) +import Data.Text.IO (putStrLn) +import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8) +import Data.ByteString (ByteString, readFile, writeFile) +import Data.Tuple (fst, snd, curry, uncurry, swap) +import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust, catMaybes) +import Data.Either (Either(..)) +import Data.List (take, drop, dropWhile, filter, reverse, lookup, zip, zip3, replicate, sortOn, concatMap, elemIndex) +import Data.Function (id, const, flip, ($), (&), (.)) +import Data.Eq (Eq(..)) +import Data.Ord (Ord(..), Down(..)) +import Data.Semigroup(Semigroup(..), (<>)) +import Data.Monoid (Monoid(..), mconcat) +import Data.Functor (Functor(..), (<$>), (<$), ($>)) +import Data.Bifunctor (Bifunctor(..), first, second) +import Data.Traversable (Traversable(..), forM, sequence) +import Data.Foldable (Foldable(..), any, all, mapM_, forM_) +import qualified Data.Time.Clock as Time +import qualified Data.Time.Format as Time + +import Text.Show (Show(..)) +import Text.Read (readMaybe) + +import Control.Applicative (Applicative(..), (<*), (*>)) +import Control.Monad (Monad(..), join, forever, mapM, forM, foldM, void, (>>=), (=<<), (>=>), (<=<)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Class (MonadState(..), get, put, modify) +import Control.Monad.Reader.Class (MonadReader(..), ask) +import Control.Exception.Safe (Exception, SomeException, IOException, MonadThrow, MonadCatch, MonadMask, throwM, try, catch, catchIO, bracket, bracketOnError) + +tshow :: Show a => a -> Text +tshow = pack . show + +headMay :: [a] -> Maybe a +headMay [] = Nothing +headMay (x:_) = Just x + +atMay :: [a] -> Int -> Maybe a +atMay [] _ = Nothing +atMay (x:_) 0 = Just x +atMay (_:xs) n = atMay xs $ n - 1 + +throwLeft :: (Exception e, MonadThrow m) => (b -> e) -> Either b a -> m a +throwLeft f (Left x) = throwM $ f x +throwLeft _ (Right x) = pure x + +log :: MonadIO m => Text -> m () +log msg = do + t <- liftIO Time.getCurrentTime + let time = Time.formatTime Time.defaultTimeLocale "[%F %T] " t + liftIO . putStrLn $ pack time <> msg + +class Pretty a where + pretty :: a -> Text + +instance Pretty Void where + pretty _ = "" diff --git a/fig-utils/src/Fig/Utils.hs b/fig-utils/src/Fig/Utils.hs new file mode 100644 index 0000000..5b328e2 --- /dev/null +++ b/fig-utils/src/Fig/Utils.hs @@ -0,0 +1,3 @@ +module Fig.Utils where + +import Fig.Prelude diff --git a/fig-utils/src/Fig/Utils/Net.hs b/fig-utils/src/Fig/Utils/Net.hs new file mode 100644 index 0000000..d0b1890 --- /dev/null +++ b/fig-utils/src/Fig/Utils/Net.hs @@ -0,0 +1,81 @@ +module Fig.Utils.Net + ( server + , client + ) where + +import Fig.Prelude + +import System.IO (IOMode(..), BufferMode(..), hClose, hSetBuffering) + +import qualified Control.Concurrent as Conc + +import qualified Network.Socket as Sock + +newtype FigNetException = FigNetException Text + deriving (Show, Eq, Ord) +instance Exception FigNetException + +resolveAddr :: forall m. + (MonadIO m, MonadThrow m) => + (Maybe Text, Text) -> + Bool -> + m Sock.AddrInfo +resolveAddr (host, port) serv = do + maddr <- liftIO $ headMay <$> Sock.getAddrInfo + (Just $ Sock.defaultHints + { Sock.addrFlags = [Sock.AI_PASSIVE | serv] + , Sock.addrSocketType = Sock.Stream + } + ) + (unpack <$> host) + (Just $ unpack port) + maybe (throwM $ FigNetException "Failed to resolve address") pure maddr + +server :: forall m. + (MonadIO m, MonadThrow m, MonadMask m) => + (Maybe Text, Text) -> + m (Handle -> Sock.SockAddr -> (IO (), IO ())) -> + m () +server loc onConn = do + addr <- resolveAddr loc True + bracket (liftIO $ Sock.openSocket addr) (liftIO . Sock.close) \sock -> do + liftIO $ Sock.setSocketOption sock Sock.ReuseAddr 1 + liftIO $ Sock.withFdSocket sock Sock.setCloseOnExecIfNeeded + liftIO $ Sock.bind sock $ Sock.addrAddress addr + liftIO $ Sock.listen sock 4096 + log $ "Listening on " <> tshow (Sock.addrAddress addr) + forever do + let toHandle = bracketOnError (liftIO $ Sock.accept sock) (liftIO . Sock.close . fst) \(conn, peer) -> + liftIO $ (,peer) <$> Sock.socketToHandle conn ReadWriteMode + bracketOnError toHandle (liftIO . hClose . fst) \(hdl, peer) -> do + liftIO $ log $ "Client " <> tshow peer <> " connected" + liftIO $ hSetBuffering hdl LineBuffering + (handler, cleanup) <- ($ peer) . ($ hdl) <$> onConn + liftIO $ Conc.forkFinally handler \res -> do + case res of + Right _ -> log $ "Client " <> tshow peer <> " disconnected" + Left err -> log $ "Client " <> tshow peer <> " disconnected: " <> tshow err + cleanup + hClose hdl + +client :: forall m. + (MonadIO m, MonadThrow m, MonadMask m) => + (Text, Text) -> + m (Handle -> (m (), m ())) -> + m () +client loc onConn = do + addr <- resolveAddr (first Just loc) False + let openConnectHandle = do + bracketOnError (liftIO $ Sock.openSocket addr) (liftIO . Sock.close) \sock -> do + liftIO . Sock.connect sock $ Sock.addrAddress addr + hdl <- liftIO $ Sock.socketToHandle sock ReadWriteMode + (handler, cleanup) <- ($ hdl) <$> onConn + pure (hdl, handler, cleanup) + bracket openConnectHandle + ( \(hdl, _, cleanup) -> do + cleanup + liftIO $ hClose hdl + ) + ( \(_, handler, _) -> do + handler + ) diff --git a/fig-utils/src/Fig/Utils/SExpr.hs b/fig-utils/src/Fig/Utils/SExpr.hs new file mode 100644 index 0000000..53a50a5 --- /dev/null +++ b/fig-utils/src/Fig/Utils/SExpr.hs @@ -0,0 +1,108 @@ +{-# Language TemplateHaskellQuotes #-} + +module Fig.Utils.SExpr + ( SExprWith(..) + , SExpr + , parseSExpr + , sexp + ) where + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as Q +import qualified Language.Haskell.TH.Syntax as Q + +import Fig.Prelude + +import Control.Monad (fail) + +import Data.Data (Data, cast) +import Data.Char (isSpace) + +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer + +data SExprWith :: Type -> Type where + SExprExt :: forall a. a -> SExprWith a + SExprSymbol :: forall a. Text -> SExprWith a + SExprString :: forall a. Text -> SExprWith a + SExprInteger :: forall a. Integer -> SExprWith a + SExprFloat :: forall a. Double -> SExprWith a + SExprList :: forall a. [SExprWith a] -> SExprWith a +deriving instance Show a => Show (SExprWith a) +deriving instance Eq a => Eq (SExprWith a) +deriving instance Ord a => Ord (SExprWith a) +deriving instance Data a => Data (SExprWith a) +deriving instance Functor SExprWith + +instance Pretty a => Pretty (SExprWith a) where + pretty (SExprExt x) = pretty x + pretty (SExprSymbol s) = s + pretty (SExprString s) = tshow s + pretty (SExprInteger i) = tshow i + pretty (SExprFloat f) = tshow f + pretty (SExprList xs) = "(" <> unwords (pretty <$> xs) <> ")" + +type SExpr = SExprWith Void + +type Parser = Parsec Void Text + +sexprWith :: forall a. Parser a -> Parser (SExprWith a) +sexprWith ext = spaces *> + ( SExprExt <$> ext + <|> SExprString . pack <$> (char '"' *> manyTill charLiteral (char '"')) + <|> SExprInteger <$> decimal + <|> SExprFloat <$> float + <|> SExprSymbol . pack <$> some symchar + <|> SExprList <$> (char '(' *> spaces *> many (spaces *> sexprWith ext <* spaces) <* char ')') + ) + where + spaces = many spaceChar + symchar = satisfy $ \c -> not (isSpace c || c `elem` special) + special :: [Char] + special = "()" + +parseSExprWith :: Parser a -> Text -> Maybe (SExprWith a) +parseSExprWith ext inp = case runParser (sexprWith ext) "" inp of + Left _ -> Nothing + Right s -> Just s + +parseSExpr :: Text -> Maybe SExpr +parseSExpr = parseSExprWith empty + +data AntiSExpr + = AntiSExpr Text + | AntiSExprSplice Text + deriving (Show, Eq, Ord, Data) + +antisexpr :: Parser AntiSExpr +antisexpr = + AntiSExprSplice . pack <$> (string ",@" *> ((:) <$> letterChar <*> many alphaNumChar)) + <|> AntiSExpr . pack <$> (char ',' *> ((:) <$> letterChar <*> many alphaNumChar)) + +antiSExprExp :: SExprWith AntiSExpr -> Maybe (Q.Q Q.Exp) +antiSExprExp (SExprExt (AntiSExpr nm)) = Just $ TH.varE (TH.mkName $ unpack nm) +antiSExprExp (SExprList xs) = do + let exps = flip fmap xs \case + SExprExt (AntiSExprSplice nm) -> TH.varE . TH.mkName $ unpack nm + s -> TH.listE [liftSExpr s] + Just $ TH.appE + (TH.conE $ TH.mkName "SExprList") + (TH.appE (TH.varE $ TH.mkName "mconcat") (TH.listE exps) ) +antiSExprExp _ = Nothing + +liftText :: Text -> Q.Q Q.Exp +liftText txt = Q.AppE (Q.VarE 'pack) <$> Q.lift (unpack txt) + +liftSExpr :: Data a => a -> Q.Q Q.Exp +liftSExpr = Q.dataToExpQ (\a -> maybe (liftText <$> cast a) antiSExprExp $ cast a) + +sexp :: Q.QuasiQuoter +sexp = Q.QuasiQuoter + { quoteExp = \s -> do + expr <- maybe (fail "parse error") pure . parseSExprWith antisexpr $ pack s + liftSExpr expr + , quotePat = \_ -> fail "unsupported s-expression in pattern context" + , quoteType = \_ -> fail "unsupported s-expression in type context" + , quoteDec = \_ -> fail "unsupported s-expression in declaration context" + } diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..5fbfcc3 --- /dev/null +++ b/flake.lock @@ -0,0 +1,27 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1696697597, + "narHash": "sha256-q26Qv4DQ+h6IeozF2o1secyQG0jt2VUT3V0K58jr3pg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "5a237aecb57296f67276ac9ab296a41c23981f56", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-23.05", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..e24e0ff --- /dev/null +++ b/flake.nix @@ -0,0 +1,214 @@ +{ + description = "fig"; + + inputs.nixpkgs.url = github:NixOS/nixpkgs/nixos-23.05; + + outputs = { self, nixpkgs }: + let + pkgs = nixpkgs.legacyPackages.x86_64-linux; + haskellPackages = pkgs.haskell.packages.ghc94.override { + overrides = self: super: { + discord-haskell = self.callCabal2nix "discord-haskell" ./deps/discord-haskell {}; + irc-conduit = self.callCabal2nix "irc-conduit" ./deps/irc-conduit {}; + irc-client = self.callCabal2nix "irc-client" ./deps/irc-client {}; + fig-utils = self.callCabal2nix "fig-utils" ./fig-utils {}; + fig-bus = self.callCabal2nix "fig-bus" ./fig-bus {}; + fig-monitor-discord = self.callCabal2nix "fig-monitor-discord" ./fig-monitor-discord {}; + fig-monitor-irc = self.callCabal2nix "fig-monitor-irc" ./fig-monitor-irc {}; + fig-monitor-bullfrog = self.callCabal2nix "fig-monitor-bullfrog" ./fig-monitor-bullfrog {}; + fig-bridge-irc-discord = self.callCabal2nix "fig-bridge-irc-discord" ./fig-bridge-irc-discord {}; + }; + }; + figBusModule = { config, lib, ... }: + let + cfg = config.colonq.services.fig-bus; + in { + options.colonq.services.fig-bus = { + enable = lib.mkEnableOption "Enable the fig message bus"; + host = lib.mkOption { + type = lib.types.str; + default = "127.0.0.1"; + description = "The host bound by the fig server"; + }; + port = lib.mkOption { + type = lib.types.port; + default = 32050; + description = "The port bound by the fig server"; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services."colonq.fig-bus" = { + after = ["network-online.target"]; + wantedBy = ["network-online.target"]; + serviceConfig = { + Restart = "on-failure"; + ExecStart = "${haskellPackages.fig-bus}/bin/fig-bus --host ${cfg.host} --port ${toString cfg.port}"; + DynamicUser = "yes"; + RuntimeDirectory = "colonq.fig-bus"; + RuntimeDirectoryMode = "0755"; + StateDirectory = "colonq.fig-bus"; + StateDirectoryMode = "0700"; + CacheDirectory = "colonq.fig-bus"; + CacheDirectoryMode = "0750"; + }; + }; + }; + }; + figMonitorDiscordModule = { config, lib, ... }: + let + cfg = config.colonq.services.fig-monitor-discord; + in { + options.colonq.services.fig-monitor-discord = { + enable = lib.mkEnableOption "Enable the fig Discord monitor"; + busHost = lib.mkOption { + type = lib.types.str; + default = "127.0.0.1"; + description = "Message bus port"; + }; + busPort = lib.mkOption { + type = lib.types.port; + default = 32050; + description = "Address of message bus"; + }; + configFile = lib.mkOption { + type = lib.types.path; + description = "Path to config file"; + default = pkgs.writeText "fig-monitor-discord.toml" '' + auth_token = "" + channel = 1064660360533135551 + ''; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services."colonq.fig-monitor-discord" = { + wantedBy = ["multi-user.target"]; + after = ["colonq.fig-bus.service"]; + serviceConfig = { + Restart = "on-failure"; + ExecStart = "${haskellPackages.fig-monitor-discord}/bin/fig-monitor-discord --bus-host ${cfg.busHost} --bus-port ${toString cfg.busPort} --config ${cfg.configFile}"; + DynamicUser = "yes"; + RuntimeDirectory = "colonq.fig-monitor-discord"; + RuntimeDirectoryMode = "0755"; + StateDirectory = "colonq.fig-monitor-discord"; + StateDirectoryMode = "0700"; + CacheDirectory = "colonq.fig-monitor-discord"; + CacheDirectoryMode = "0750"; + }; + }; + }; + }; + figMonitorIRCModule = { config, lib, ... }: + let + cfg = config.colonq.services.fig-monitor-irc; + in { + options.colonq.services.fig-monitor-irc = { + enable = lib.mkEnableOption "Enable the fig IRC monitor"; + busHost = lib.mkOption { + type = lib.types.str; + default = "127.0.0.1"; + description = "Message bus port"; + }; + busPort = lib.mkOption { + type = lib.types.port; + default = 32050; + description = "Address of message bus"; + }; + configFile = lib.mkOption { + type = lib.types.path; + description = "Path to config file"; + default = pkgs.writeText "fig-monitor-irc.toml" '' + host = "colonq.computer" + port = 26697 + nick = "discord" + sendchannel = "#cyberspace" + channels = ["#cyberspace"] + ''; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services."colonq.fig-monitor-irc" = { + wantedBy = ["multi-user.target"]; + after = ["colonq.fig-bus.service"]; + serviceConfig = { + Restart = "on-failure"; + ExecStart = "${haskellPackages.fig-monitor-irc}/bin/fig-monitor-irc --bus-host ${cfg.busHost} --bus-port ${toString cfg.busPort} --config ${cfg.configFile}"; + DynamicUser = "yes"; + RuntimeDirectory = "colonq.fig-monitor-irc"; + RuntimeDirectoryMode = "0755"; + StateDirectory = "colonq.fig-monitor-irc"; + StateDirectoryMode = "0700"; + CacheDirectory = "colonq.fig-monitor-irc"; + CacheDirectoryMode = "0750"; + }; + }; + }; + }; + figBridgeIRCDiscordModule = { config, lib, ... }: + let + cfg = config.colonq.services.fig-bridge-irc-discord; + in { + options.colonq.services.fig-bridge-irc-discord = { + enable = lib.mkEnableOption "Enable the fig IRC/Discord bridge"; + busHost = lib.mkOption { + type = lib.types.str; + default = "127.0.0.1"; + description = "Message bus port"; + }; + busPort = lib.mkOption { + type = lib.types.port; + default = 32050; + description = "Address of message bus"; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services."colonq.fig-bridge-irc-discord" = { + wantedBy = ["multi-user.target"]; + after = ["colonq.fig-bus.service"]; + serviceConfig = { + Restart = "on-failure"; + ExecStart = "${haskellPackages.fig-bridge-irc-discord}/bin/fig-bridge-irc-discord --bus-host ${cfg.busHost} --bus-port ${toString cfg.busPort}"; + DynamicUser = "yes"; + RuntimeDirectory = "colonq.fig-bridge-irc-discord"; + RuntimeDirectoryMode = "0755"; + StateDirectory = "colonq.fig-bridge-irc-discord"; + StateDirectoryMode = "0700"; + CacheDirectory = "colonq.fig-bridge-irc-discord"; + CacheDirectoryMode = "0750"; + }; + }; + }; + }; + in { + devShells.x86_64-linux.default = haskellPackages.shellFor { + packages = hspkgs: with hspkgs; [ + fig-utils + fig-bus + fig-monitor-discord + fig-monitor-irc + fig-monitor-bullfrog + fig-bridge-irc-discord + ]; + withHoogle = true; + buildInputs = [ + ]; + }; + packages.x86_64-linux = { + default = haskellPackages.fig-bus; + figBus = haskellPackages.fig-bus; + figMonitorDiscord = haskellPackages.fig-monitor-discord; + figMonitorIRC = haskellPackages.fig-monitor-irc; + figMonitorBullfrog = haskellPackages.fig-monitor-bullfrog; + figBridgeIRCDiscord = haskellPackages.fig-bridge-irc-discord; + }; + apps.x86_64-linux.default = { + type = "app"; + program = "${haskellPackages.fig-bus}/bin/fig-bus"; + }; + nixosModules = { + figBus = figBusModule; + figMonitorDiscord = figMonitorDiscordModule; + figMonitorIRC = figMonitorIRCModule; + figBridgeIRCDiscord = figBridgeIRCDiscordModule; + }; + }; +} diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..2b4b7a3 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,28 @@ +cradle: + multi: + - path: "./fig-utils/src/" + config: { cradle: { cabal: { component: "fig-utils:lib:fig-utils" } } } + - path: "./fig-bus/src/" + config: { cradle: { cabal: { component: "fig-bus:lib:fig-bus" } } } + - path: "./fig-bus/main/" + config: { cradle: { cabal: { component: "fig-bus:exe:fig-bus" } } } + - path: "./fig-monitor-twitch/src/" + config: { cradle: { cabal: { component: "fig-monitor-twitch:lib:fig-monitor-twitch" } } } + - path: "./fig-monitor-twitch/main/" + config: { cradle: { cabal: { component: "fig-monitor-twitch:exe:fig-monitor-twitch" } } } + - path: "./fig-monitor-discord/src/" + config: { cradle: { cabal: { component: "fig-monitor-discord:lib:fig-monitor-discord" } } } + - path: "./fig-monitor-discord/main/" + config: { cradle: { cabal: { component: "fig-monitor-discord:exe:fig-monitor-discord" } } } + - path: "./fig-monitor-irc/src/" + config: { cradle: { cabal: { component: "fig-monitor-irc:lib:fig-monitor-irc" } } } + - path: "./fig-monitor-irc/main/" + config: { cradle: { cabal: { component: "fig-monitor-irc:exe:fig-monitor-irc" } } } + - path: "./fig-monitor-bullfrog/src/" + config: { cradle: { cabal: { component: "fig-monitor-bullfrog:lib:fig-monitor-bullfrog" } } } + - path: "./fig-monitor-bullfrog/main/" + config: { cradle: { cabal: { component: "fig-monitor-bullfrog:exe:fig-monitor-bullfrog" } } } + - path: "./fig-bridge-irc-discord/src/" + config: { cradle: { cabal: { component: "fig-bridge-irc-discord:lib:fig-bridge-irc-discord" } } } + - path: "./fig-bridge-irc-discord/main/" + config: { cradle: { cabal: { component: "fig-bridge-irc-discord:exe:fig-bridge-irc-discord" } } } |
