diff --git a/.env.example b/.env.example index 31f56b71..2d641d2f 100644 --- a/.env.example +++ b/.env.example @@ -6,5 +6,7 @@ CATAPI_TOKEN=12345678-1234-1234-1234-123456789012 EXEC_GROUP=123456789123456789 MODERATOR_GROUP=321654987321654987 SUPERUSER_GROUP=147258369147258369 +SERVER_ID=314159265358979323 ALLOW_GIT_UPDATE=False +EMOJI_SERVERS=[121213131414151516] # NOTE: YOU MUST HAVE A NEWLINE AT THE END OF THE FILE diff --git a/.gitignore b/.gitignore index 6f78a42e..57468f69 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ database* *.cabal stack.yaml.lock .gitattributes +.vscode diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f72e1d08..0bc1c47e 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -4,24 +4,44 @@ Welcome to the [University of Warwick Tabletop and Roleplaying Society](https:// Please feel free to contribute to the code in whatever way you are able. We're more than happy to accept new code, bug fixes, documentation, issues, and anything else you think will improve the bot! If you do start work on an issue, please first let us know in the issue's thread or in our Discord server to avoid competing pull requests. -## Code of Conduct +**Our society has a [Code of Conduct](https://www.warwicktabletop.co.uk/page/codeofconduct/). We expect it to be upheld by contributors in all our online spaces the same way we'd expect it to be upheld by attendees of our events.** -Our society has a [Code of Conduct](https://www.warwicktabletop.co.uk/page/codeofconduct/). We expect it to be upheld by contributors in all our online spaces the same way we'd expect it to be upheld by attendees of our events. +## What can I contribute? -## Good Practice Recommendations +We're happy to accept any contribution, big or small. You can find our list of issues [here](https://github.com/WarwickTabletop/tablebot/issues), which details bugs and feature requests. Both code (with documentation) and documentation alone is accepted - we want this project to be as accessible as possible, so any contributions must come with documentation or add documentation. -Here are some good practice tips for git and this project. +If you think of a feature you'd like added or find a bug in the current implementation please do create a new ticket! There's no obligation to implement the issue. If you don't have any ideas but do want to get involved with programming you can check the issues page for new features and fixes to work on. If you're not too familiar with Haskell or our codebase, look out for the "good first issue" label. We put this on issues that we think would be good for newcomers to the language/project to get started on. -* Whenever a new feature is being worked on, create a new branch on your forked repo -* When a feature is ready to be merged into the bot, make a pull request from the feature branch to the main repo -* Before making a pull request, make sure your branch is up to date with main (and that it compiles and complies with `ormolu` - see below for details) so that it can be merged without hassle -* Write comments! This project will be maintained by many people, and it can be difficult to work out what others' code does -* To communicate with the maintainers, please join the [Tabletop Discord server](https://warwicktabletop.co.uk/discord) and give yourself the @computer_person role to join the developer channel -* If you need help finding a function to do a particular task, you can search on [Hoogle](https://hoogle.haskell.org/). The two libraries that deal with parsing are `Text.Megaparsec` and `Control.Monad.Combinators`, and `Discord` is the package that deals with Discord itself. You can filter by package if that helps to find certain functions +If you have trouble at any time, please do ask for help in an issue thread or on our Discord. The maintainers generally communicate in the [Tabletop Discord server](https://warwicktabletop.co.uk/discord). The channel we use, #computers-were-a-mistake, is opt-in so you'll need to give yourself the @computer_person role in #roles. Finally, you can also check out the [tutorials](tutorials) in the repository and pre-existing solutions in the code for guidance. -You can check out the [README](README.md) for a brief overview on how to set up a local bot for testing. If you've never done something like this before, see the bottom of this document for a walkthrough. +## How to contribute -## Ormolu +### The basics + +If you'd like to contribute code, these are the steps you'll need to follow along with some tips. (If you've contributed to an open-source Haskell project before, you likely know all of this.) + +* You'll need to fork this repo if you haven't already, and then create a branch for the feature you're implementing. Please split up features into different branches where you can. +* When a feature is ready to be merged into the bot, make a pull request from the feature branch to the main repo. In the next section we'll talk about pull requests. +* Before making a pull request (PR), **make sure your branch is up to date with main**. The CI must also not complain, so the code must compile and not throw any formatting errors. We use `ormolu` to check for the latter, which is detailed later. +* If you need help finding a function to do a particular task, you can search on [Hoogle](https://hoogle.haskell.org/). The two libraries that deal with parsing are `Text.Megaparsec` and `Control.Monad.Combinators`, and `Discord` is the package that deals with Discord itself. You can filter by package if that helps to find certain functions. + +You can check out the [README](README.md) for a brief overview on how to set up a local bot for testing. If you've never done something like this before, see [SETUP.md](SETUP.md). + +### Writing good Pull Requests (PRs) + +Writing good PRs is hard. As such, here are some important points to consider when writing your PR to make it easier for the reviewer. + +* **Ask yourself: what does this PR contribute?** It is very important that you're clear about all of the features being added, because they justify the changes you have made and point out what exactly needs testing. Mention _everything_ even if it is just cleaning up a file - this makes it clear what the point is of each change and doesn't leave the reviewer guessing why you've added a certain change. +* **Documentation is key.** PRs without documentation will be rejected. A few points to consider about documentation: + * Functions should have top-level documentation explaining what they do (even if it is very brief) unless they are self-evident. Classes should be justified in the same way. Use Haddock style. + * In larger implementations, it may help to talk about the high-level structure of your implementation - e.g. you might have a section of your plugin that deals with parsing messages, another which deals with some specific case, another which deals with the general case and so on. Make it clear how these parts interact. Splitting your implementation into multiple files may help here, with a base file that imports each auxiliary file and puts the results within those files together. + * Haskell code has a habit of being extremely abstract, and talking about it in the abstract does not aid understanding. Give concrete examples of how the abstract is used to justify its existence - instead of solely saying "we have a parser that doesn't look at `t`", back it up with an example like "this is used within a Discord interaction, so doesn't necessarily have an associated message". +* **Remember the plugin writer as well as the end user.** If you've written something that changes how plugins are written, update existing tutorials or add new ones. Make sure that the API you're defining is clear and easy to use, so doesn't put too much burden on someone writing a plugin. +* **Try to keep your PR small.** If you can split your work into multiple PRs, please do - the smaller a PR is, the more likely your reviewer will be able to understand it and thus accept it. + +If you follow these steps, it becomes much easier for the reviewer to understand your code and thus feel confident about accepting it. This also allows the reviewer to make more helpful suggestions about the code itself - both allowing them to verify that the code does what you say it does, and that you've implemented it in a helpful way. The review process should help you write better code as well as making Tablebot as a whole better. + +### Ormolu To maintain consistent formatting you must use Ormolu, which can be installed via stack: @@ -33,7 +53,7 @@ Then you can run it on every file via: You can see full documentation on the [Ormolu repo](https://github.com/tweag/ormolu#usage). -### Running Ormolu automatically with git +#### Running Ormolu automatically with git You may also wish to set up Ormolu to run when you stage a file (get ready to commit it) - this can be done using `.gitattributes` and `.gitconfig` as follows. @@ -55,52 +75,3 @@ You may also wish to set up Ormolu to run when you stage a file (get ready to co That's it! (With thanks to Sam Coy for explaining this process) -## What can I work on? - -We're happy to accept any contribution, big or small. You can find our list of issues [here](https://github.com/WarwickTabletop/tablebot/issues). If you think of a feature you'd like added or a bug in the current implementation please do create a new ticket! There's no obligation to implement the issue. If you don't have any ideas but do want to get involved with programming you can check the issues page for new features and fixes to work on. If you're not too familiar with Haskell or our codebase, look out for the "good first issue" label. We put this on issues that we think would be good for newcomers to the language/project to get started on. - -If you have trouble at any time, please do ask for help in an issue thread or on our Discord. You can also check out the [tutorials](tutorials) in the repository and pre-existing solutions in the code for guidance. - -## Setup from Scratch - -If at any point something doesn't work, restart your computer first and try it again. If the problem persists please feel free to ask for help in the [Discord server](https://www.warwicktabletop.co.uk/discord/). Sections are marked depending on what OS they rely on, if any. - -1. git, wsl, and vscode setup - 1. github - 1. Create a GitHub account - 2. Go to - 3. Click fork on the repo (should be top right) (this creates your own version of the repo) - 4. Take note of the url that your forked repo is on - 2. wsl and git (Windows) - 1. Install wsl by going to , and make sure it's in the right click context menu of folders - 2. Navigate to an empty folder on your computer that you want to do your programming from (the project folder) - 3. Shift-right click in the project folder, and click "open linux shell here" - 4. Type `git clone ` into the terminal - 5. The folder should be filled with a bunch of files and folders - 3. terminal and git (Linux) - 1. Navigate to an empty folder on your computer that you want to do your programming from (the project folder) - 2. Shift-right click in the project folder and press "open in terminal" - 3. Type `git clone ` into the terminal - 4. The folder should be filled with a bunch of files and folders - 4. vscode - 1. Install vscode from - 2. Install this - 3. From a terminal opened in the project folder, type `code .` - 4. There should soon be a window which has all the folders and files open on the left hand side -2. Haskell setup - 1. In any linux terminal window (wsl or the linux terminal itself), type `curl -sSL https://get.haskellstack.org/ | sh`, allowing sudo access and providing passwords as needed - 2. In the linux terminal window opened from the project folder (or the terminal open in the vscode window) run `stack build`, and then wait until it's done - 3. This will take a long time - 4. Make some tea, or maybe some coffee or hot chocolate - 5. If it didn't work, reopen all terminal windows and try again. if that doesn't work, restart your computer and try again - 6. Install this - 7. Open a file and marvel at the colours, and the fact you can hover over things and see values and stuff -3. Discord and Environment variables - 1. Create a file in the top level of the project folder called `.env`, based on the template in `.env.example` - 2. Follow the instructions in [Environment File Setup](README.md#environment-file-setup) to fill in the `.env`. Make sure to get a `DISCORD_TOKEN` and a `SQLITE_FILENAME` (which can be named anything, but use something like `database.db`) - 3. To run the bot, type `stack run` into the terminal, and the bot will start to run - 4. Make sure to invite the bot to a server so you can test it out! - -Congratulations, you now know the very basics needed to set up your own tablebot! - -To learn more about git, you should look up a tutorial or watch this video: diff --git a/ChangeLog.md b/ChangeLog.md index 1dd16b9c..9e0d73c3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,4 @@ # Changelog for tablebot ## Unreleased changes +- Allow configuration of which servers are allowed to provide emoji \ No newline at end of file diff --git a/README.md b/README.md index b3373169..e8ee3b9a 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ An extendable Discord bot framework written on top of [`discord-haskell`](https://github.com/aquarial/discord-haskell). -If you're new to this project, or completely new to git, and Haskell, you might be interested in looking at the [Setup from Scratch](CONTRIBUTING.md#setup-from-scratch) section in the [contributor's guide](CONTRIBUTING.md). If you want tutorials on making your first plugin or how exceptions work, checkout the tutorials in the [tutorials](tutorials) folder. +If you're new to this project, or completely new to git, and Haskell, you might be interested in looking at the [Setup from Scratch](SETUP.md) guide. If you want to contribute, please consult the [contributor's guide](CONTRIBUTING.md). If you want tutorials on making your first plugin or how exceptions work, checkout the tutorials in the [tutorials](tutorials) folder. ## Environment file setup @@ -23,9 +23,18 @@ Create a `.env` file containing the following keys. Consult `.env.example` if yo * `EXEC_GROUP` (optional) - the group ID assigned to exec members. * `MODERATOR_GROUP` (optional) - the group ID assigned to moderator members. * `SUPERUSER_GROUP` (optional) - the group ID assigned to the superuser. Strongly recommended +* `SERVER_ID` (optional) - either `global` or the id of the server the bot will mainly be deployed in. Application commands will be + registered here. If absent, application commands won't be registered. +* `EMOJI_SERVERS` (optional) - a list of server IDs that the bot will search for emoji within. +* `ALLOW_GIT_UPDATE` (optional) - a `true` or `false` value that determines whether the bot can automatically load data from the repository. + **Warning!** Be very careful with setting this to true; if you haven't set up permissions properly on your repo and your discord servers then things can go wrong! The three Group settings are optional, but without them any commands that require elevated permissions will not be able -to be called when DEBUG is false. Users with the superuser group are able to run every command (including some dangerous +to be called when `DEBUG` is false. Users with the superuser group are able to run every command (including some dangerous ones), so caution should be used when setting these up. -If you have any difficulties setting it up, see the [contributor's guide](CONTRIBUTING.md) for a walkthrough. +If you have any difficulties setting it up, see the [setup guide](SETUP.md) for a walkthrough. + +## Importing this bot and running it yourself. + +If you like, rather than directly running this bot you can run it yourself with minor tweaks. An example of this is in `app/Main.hs` - tweak this to your needs and then run `stack run` as per usual. \ No newline at end of file diff --git a/SETUP.md b/SETUP.md new file mode 100644 index 00000000..0b3c6e10 --- /dev/null +++ b/SETUP.md @@ -0,0 +1,46 @@ +# Setup from Scratch + +This document details the setup process of downloading a development copy of Tablebot. +This was originally authored by Benji (Git won't reflect this as it was taken out of CONTRIBUTING.md). + +If at any point something doesn't work, restart your computer first and try it again. If the problem persists please feel free to ask for help in the [Discord server](https://www.warwicktabletop.co.uk/discord/). Sections are marked depending on what OS they rely on, if any. + +1. git, wsl, and vscode setup + 1. github + 1. Create a GitHub account + 2. Go to + 3. Click fork on the repo (should be top right) (this creates your own version of the repo) + 4. Take note of the url that your forked repo is on + 2. wsl and git (Windows) + 1. Install wsl by going to , and make sure it's in the right click context menu of folders + 2. Navigate to an empty folder on your computer that you want to do your programming from (the project folder) + 3. Shift-right click in the project folder, and click "open linux shell here" + 4. Type `git clone ` into the terminal + 5. The folder should be filled with a bunch of files and folders + 3. terminal and git (Linux) + 1. Navigate to an empty folder on your computer that you want to do your programming from (the project folder) + 2. Shift-right click in the project folder and press "open in terminal" + 3. Type `git clone ` into the terminal + 4. The folder should be filled with a bunch of files and folders + 4. vscode + 1. Install vscode from + 2. Install this + 3. From a terminal opened in the project folder, type `code .` + 4. There should soon be a window which has all the folders and files open on the left hand side +2. Haskell setup + 1. In any linux terminal window (wsl or the linux terminal itself), type `curl -sSL https://get.haskellstack.org/ | sh`, allowing sudo access and providing passwords as needed + 2. In the linux terminal window opened from the project folder (or the terminal open in the vscode window) run `stack build`, and then wait until it's done + 3. This will take a long time + 4. Make some tea, or maybe some coffee or hot chocolate + 5. If it didn't work, reopen all terminal windows and try again. if that doesn't work, restart your computer and try again + 6. Install this + 7. Open a file and marvel at the colours, and the fact you can hover over things and see values and stuff +3. Discord and Environment variables + 1. Create a file in the top level of the project folder called `.env`, based on the template in `.env.example` + 2. Follow the instructions in [Environment File Setup](README.md#environment-file-setup) to fill in the `.env`. Make sure to get a `DISCORD_TOKEN` and a `SQLITE_FILENAME` (which can be named anything, but use something like `database.db`) + 3. To run the bot, type `stack run` into the terminal, and the bot will start to run + 4. Make sure to invite the bot to a server so you can test it out! + +Congratulations, you now know the very basics needed to set up your own tablebot! + +To learn more about git, you should look up a tutorial or watch this video: diff --git a/app/Main.hs b/app/Main.hs index 5975eea9..d14d8e3d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,38 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where -import Control.Concurrent.MVar (MVar, newMVar, swapMVar) -import Control.Monad (forever, unless) -import Control.Monad.Extra -import Data.Maybe (fromMaybe) -import Data.Text (pack) -import Data.Text.Encoding (encodeUtf8) -import LoadEnv (loadEnv) -import Paths_tablebot (version) -import System.Environment (getEnv, lookupEnv) -import System.Exit (die) -import Tablebot (runTablebot) -import Tablebot.Internal.Administration -import Tablebot.Plugins (plugins) -import Tablebot.Utility.Types -import Text.Regex.PCRE +import Data.Text (Text) +import Tablebot (BotConfig (..), runTablebotWithEnv) +import Tablebot.Plugins (allPlugins) -- @main@ runs forever. This allows bot reloading by fully shutting down the bot and letting it restart. main :: IO () -main = do - -- fetch the version info as soon after building to reduce the likelihood that it changes between build and run - gv <- gitVersion - let vInfo = VInfo gv version - rFlag <- newMVar Reload :: IO (MVar ShutdownReason) - whileM $ do - _ <- swapMVar rFlag Reload - loadEnv - dToken <- pack <$> getEnv "DISCORD_TOKEN" - unless (encodeUtf8 dToken =~ ("^[A-Za-z0-9_-]{24}[.][A-Za-z0-9_-]{6}[.][A-Za-z0-9_-]{27}$" :: String)) $ - die "Invalid token format. Please check it is a bot token" - prefix <- pack . fromMaybe "!" <$> lookupEnv "PREFIX" - dbpath <- getEnv "SQLITE_FILENAME" - runTablebot vInfo dToken prefix dbpath (plugins rFlag) - exit <- swapMVar rFlag Reload - restartAction exit - pure $ not (restartIsTerminal exit) - putStrLn "Tablebot closed" +main = + runTablebotWithEnv allPlugins $ + BotConfig + { gamePlaying = game, + rootHelpText = rootBody + } + +game :: Text -> Text +game prefix = "with dice. Prefix is `" <> prefix <> "`. Call `" <> prefix <> "help` for help" + +rootBody :: Text +rootBody = + "**Tabletop Bot**\n\ + \This friendly little bot provides several tools to help with\ + \ the running of the Warwick Tabletop Games and Role-Playing Society Discord server." diff --git a/docs/Roll.md b/docs/Roll.md index 1b5c6127..d8d11774 100644 --- a/docs/Roll.md +++ b/docs/Roll.md @@ -22,7 +22,7 @@ As well as the arithmetic operators above, dice can be rolled, hence the name of The basic format for this is `dX` where X is some number, meaning a single die of size X. Multiple dice can be rolled using `YdX`, meaning that Y dice are rolled of size X. Parentheses can be used for both Y and X in this case. If Y is greater than a number determined by the bot owner (150 by default), the roll will not be executed. This is the same number that governs the total amount of RNG calls allowed within a command's execution. -In addition to the above, there is syntax for rolling dice with arbitrary sides - `d{4,7,19,-5}`. This results in a die that is equally likely to result in four, seven, nineteen, or minus five. These numbers could be any expression instead. +In addition to the above, there is syntax for rolling dice with arbitrary sides - `d{4, 7, 19, -5}`. This results in a die that is equally likely to result in four, seven, nineteen, or minus five. These numbers could be any expression instead. There is support for stacking dice. This means that if you write `2d4d5d6`, it will be parsed and executed as `((2d4)d5)d6`. Operations can be applied to the dice in this stack. @@ -60,15 +60,30 @@ With the introduction of this notation, it is worth noting that the normal (with ## Lists -As well as simple expressions, basic list expressions can be formed. You can form a basic list using `{e,f,g}`, where `e`, `f`, and `g` are expressions as seen before. Additionally, by using `N#YdX` syntax, you can roll `N` amount of dice following `YdX`. +As well as simple expressions, basic list expressions can be formed. You can form a basic list using `{e, f, g}`, where `e`, `f`, and `g` are expressions as seen before. Additionally, by using `N#YdX` syntax, you can roll `N` amount of dice following `YdX`. As an addendum to custom dice, if a list value is bracketed then it can be used in custom dice. For example, `5d(4#4d6)` rolls five dice, whose sides are determined by rolling 4d6 4 times. Do note that laziness still applies here, meaning that the RNG cap can be very quickly reached. Lists are limited to 50 items long currently (which is configurable). +## Complex Operations + +There are two operators that are more complex and have specific organisational requirements, that allow for a great deal of control in the program. With them comes more complex structures for expressions as a whole. + +If statements take an expression, and then two either integer values or list values. If the expression is non-zero, the first value is returned. If the expression is zero, the second value is returned. The syntax for it is `if expression then t else f`, where `expression` is an integer value, and `t` and `f` are both either integer values or list values. Only one of `t` or `f` is ever evaluated. + +Var statements take a name and either an integer value or a list, and set a variable with that name to that value. If the var statement is lazy (with an exclamation mark before the variable name) the value is recalculated every time the variable is used. A var statement returns the value on the left side. To create and use list variables, they must be prepended with `l_`. The syntax can be something like `var name = value`, `var !name = value`, or `var l_name = value`, or so on. These bound values can then be used in other calculations. Variable names consist only have lower case letters and underscores. + +To fully utilise these expression types, statements have been made, which, when constructed together with a value, creates a program. A statement is an integer value or list value followed by a semicolon. Below are a couple example programs (which are multiple statements followed by a single value). One quality of life feature is that a lazy var expression won't be evaluated until the variable is first used. + +- `var l_list = (2d6)#3d6; {length(l_list), minimum(l_list), maximum(l_list), sum(l_list)/length(l_list)}` + - Get the length, minimum, maximum, and average value of a random list. +- `var !k = 1d20; var t = k; var !t_iseven = if mod(t, 2) then 0 else 1; if t_iseven then k * t + 20 else t` + - Create a lazy variable `k`. Evaluate it into a variable `t`. Check whether `t` is even, and place in a variable. Depending on whether `t` is even or not, either output another random number times by `t` (and add 20 to distinguish it), or just output `t`. + ## Functions -Here are all the functions, what they take, and what they return. +Here are all the functions, what they take, and what they return. They are called with `name(arg1, arg2)`. ### Returns an Integer - abs (integer) - the absolute value of an integer @@ -91,12 +106,15 @@ Here are all the functions, what they take, and what they return. - take (integer, list) - take the first `n` values from a list, where `n` is the integer given - between (integer, integer) - generate a list between the two given integers (inclusive) - concat (list, list) - concatenate two lists together +- replicate (integer, integer) - create a list of length the first integer, consisting of elements of only the second element +- set (integer, integer, list) - set the item at the index of the first integer to the value of the second integer in the given list +- insert (integer, integer, list) - insert the item at the index of the first integer to the value of the second integer in the given list # Statistics As well as generating values, statistics based off of expressions can be found. There is a total time limit of 10 seconds for this command, with 5 seconds given to calculations and 5 seconds given to generating the bar chart. -To get these statistics, calling the `roll` command with the `stats` subcommand will generate the requested statistics. The expression given has to return an integer. +To get these statistics, calling the `roll` command with the `stats` subcommand will generate the requested statistics. The expression given has to return an integer. Stats can only be generated on single expressions and not programs. The bot will give the mean, the standard deviation, and the top ten most common values of the distribution, as well as graphing the entire distribution. diff --git a/package.yaml b/package.yaml index 7b891610..c641120c 100644 --- a/package.yaml +++ b/package.yaml @@ -20,55 +20,55 @@ extra-source-files: description: Please see the README on GitHub at dependencies: - - base >= 4.7 && < 5 - - extra - - discord-haskell - - emoji - - text - - text-icu - - transformers - - load-env - - megaparsec - - persistent - - persistent-sqlite - - persistent-template - - random - - esqueleto - - monad-logger - - time - - aeson - - bytestring - - yaml - - http-conduit - - raw-strings-qq - - template-haskell - - timezone-olson - - duckling - - unordered-containers - - bytestring - - req - - http-client - - data-default - - exception-transformers - - resourcet - - resource-pool - - containers - - th-printf - - mtl - - safe - - edit-distance - - unliftio - - process - - Chart - - Chart-diagrams - - diagrams-core - - diagrams-lib - - diagrams-rasterific - - JuicyPixels - - split - - regex-pcre - - distribution - +- base >= 4.7 && < 5 +- discord-haskell +- emoji +- text +- text-icu +- transformers +- load-env +- megaparsec +- persistent +- persistent-sqlite +- persistent-template +- random +- esqueleto +- monad-logger +- time +- aeson +- bytestring +- yaml +- http-conduit +- raw-strings-qq +- template-haskell +- timezone-olson +- duckling +- unordered-containers +- bytestring +- req +- http-client +- data-default +- exception-transformers +- resourcet +- resource-pool +- containers +- th-printf +- mtl +- safe +- edit-distance +- unliftio +- Chart +- Chart-diagrams +- diagrams-core +- diagrams-lib +- diagrams-rasterific +- JuicyPixels +- split +- regex-pcre +- scientific +- distribution +- extra +- process library: source-dirs: src diff --git a/src/Tablebot.hs b/src/Tablebot.hs index 4338a95a..0aea8a8a 100644 --- a/src/Tablebot.hs +++ b/src/Tablebot.hs @@ -9,27 +9,25 @@ -- Portability : POSIX -- -- This module contains the main runner for Tablebot. If you're just looking to --- run the bot with existing plugins, importing this and your favourite plugins +-- run the bot with existing plugins, import this and your favourite plugins -- from "Tablebot.Plugins". module Tablebot ( runTablebot, + runTablebotWithEnv, + BotConfig (..), ) where import Control.Concurrent - ( MVar, - ThreadId, - newEmptyMVar, - newMVar, - putMVar, - takeMVar, - ) +import Control.Monad.Extra import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (NoLoggingT (runNoLoggingT)) import Control.Monad.Reader (runReaderT) import Control.Monad.Trans.Resource (runResourceT) -import qualified Data.Map as M +import Data.Map as M (empty) +import Data.Maybe (fromMaybe) import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO (putStrLn) import Database.Persist.Sqlite ( createSqlitePool, @@ -38,25 +36,68 @@ import Database.Persist.Sqlite ) import Discord import Discord.Internal.Rest -import Tablebot.Handler (eventHandler, killCron, runCron) -import Tablebot.Internal.Administration (adminMigration, currentBlacklist, removeBlacklisted) +import LoadEnv (loadEnv) +import Paths_tablebot (version) +import System.Environment (getEnv, lookupEnv) +import System.Exit (die) +import Tablebot.Handler (eventHandler, killCron, runCron, submitApplicationCommands) +import Tablebot.Internal.Administration + ( ShutdownReason (Reload), + adminMigration, + currentBlacklist, + gitVersion, + removeBlacklisted, + restartAction, + restartIsTerminal, + ) import Tablebot.Internal.Plugins import Tablebot.Internal.Types +import Tablebot.Plugins (addAdministrationPlugin) import Tablebot.Utility -import Tablebot.Utility.Help +import Tablebot.Utility.Help (generateHelp) +import Text.Regex.PCRE ((=~)) + +-- | runTablebotWithEnv @plugins@ runs the bot using data found in the .env +-- file with the @[CompiledPlugin]@ given. If you're looking to run the bot as +-- detailed in the README (i.e. using data from .env), you should call this +-- function. +runTablebotWithEnv :: [CompiledPlugin] -> BotConfig -> IO () +runTablebotWithEnv plugins config = do + -- fetch the version info as soon after building to reduce the likelihood that it changes between build and run + gv <- gitVersion + let vInfo = VInfo gv version + rFlag <- newMVar Reload :: IO (MVar ShutdownReason) + whileM $ do + _ <- swapMVar rFlag Reload + loadEnv + dToken <- pack <$> getEnv "DISCORD_TOKEN" + unless (encodeUtf8 dToken =~ ("^[A-Za-z0-9_-]{24}[.][A-Za-z0-9_-]{6}[.][A-Za-z0-9_-]{38}$" :: String)) $ + die "Invalid token format. Please check it is a bot token" + prefix <- pack . fromMaybe "!" <$> lookupEnv "PREFIX" + dbpath <- getEnv "SQLITE_FILENAME" + runTablebot vInfo dToken prefix dbpath (addAdministrationPlugin rFlag plugins) config + exit <- swapMVar rFlag Reload + restartAction exit + pure $ not (restartIsTerminal exit) + putStrLn "Bot closed" --- | runTablebot @dToken@ @prefix@ @dbpath@ @plugins@ runs the bot using the --- given Discord API token @dToken@ and SQLite connection string @dbpath@. Only --- the plugins provided by @plugins@ are run, and all commands are prefixed --- with @prefix@. +-- | runTablebot @vinfo@ @dToken@ @prefix@ @dbpath@ @plugins@ @config@ runs the +-- bot using the given Discord API token @dToken@ and SQLite connection string +-- @dbpath@. In general, you should prefer @runTablebotWithEnv@ as it gets all +-- of the required data for you, but this is exported for if you have weird +-- setup requirements or don't want to use the administration plugin. +-- Only the plugins provided by @plugins@ are run, and all commands +-- are prefixed with @prefix@. @config@ details how the bot should present +-- itself to users, allowing programmers to replace the Tablebot-specific text +-- with their own. -- The plugins given are combined into a single plugin with their combined -- functionality. Each migration present in the combined plugin is run, and -- each cron job and handler is set up. -- This creates a small pool of database connections used by the event handler, -- builds an event handler and starts cron jobs. It also kills the cron jobs on -- bot close. -runTablebot :: VersionInfo -> Text -> Text -> FilePath -> [CompiledPlugin] -> IO () -runTablebot vinfo dToken prefix dbpath plugins = +runTablebot :: VersionInfo -> Text -> Text -> FilePath -> [CompiledPlugin] -> BotConfig -> IO () +runTablebot vinfo dToken prefix dbpath plugins config = do debugPrint ("DEBUG enabled. This is strongly not recommended in production!" :: String) -- Create multiple database threads. @@ -67,7 +108,7 @@ runTablebot vinfo dToken prefix dbpath plugins = blacklist <- runResourceT $ runNoLoggingT $ runSqlPool currentBlacklist pool let filteredPlugins = removeBlacklisted blacklist plugins -- Combine the list of plugins into both a combined plugin - let !plugin = generateHelp $ combinePlugins filteredPlugins + let !plugin = generateHelp (rootHelpText config) $ combinePlugins filteredPlugins -- Run the setup actions of each plugin and collect the plugin actions into a single @PluginActions@ instance allActions <- mapM (runResourceT . runNoLoggingT . flip runSqlPool pool) (combinedSetupAction plugin) let !actions = combineActions allActions @@ -77,7 +118,7 @@ runTablebot vinfo dToken prefix dbpath plugins = mapM_ (\migration -> runSqlPool (runMigration migration) pool) $ combinedMigrations plugin -- Create a var to kill any ongoing tasks. mvar <- newEmptyMVar :: IO (MVar [ThreadId]) - cacheMVar <- newMVar (TCache M.empty vinfo) :: IO (MVar TablebotCache) + cacheMVar <- newMVar (TCache M.empty M.empty vinfo) :: IO (MVar TablebotCache) userFacingError <- runDiscord $ def @@ -91,7 +132,10 @@ runTablebot vinfo dToken prefix dbpath plugins = -- (which can just happen due to databases being unavailable -- sometimes). runReaderT (mapM (runCron pool) (compiledCronJobs actions) >>= liftIO . putMVar mvar) cacheMVar - liftIO $ putStrLn "Tablebot lives!" + + submitApplicationCommands (compiledApplicationCommands actions) cacheMVar + + liftIO $ putStrLn "The bot lives!" sendCommand (UpdateStatus activityStatus), -- Kill every cron job in the mvar. discordOnEnd = takeMVar mvar >>= killCron @@ -103,10 +147,9 @@ runTablebot vinfo dToken prefix dbpath plugins = { updateStatusOptsSince = Nothing, updateStatusOptsGame = Just - ( Activity - { activityName = "with dice. Prefix is `" <> prefix <> "`. Call `" <> prefix <> "help` for help", - activityType = ActivityTypeGame, - activityUrl = Nothing + ( def + { activityName = gamePlaying config prefix, + activityType = ActivityTypeGame } ), updateStatusOptsNewStatus = UpdateStatusOnline, diff --git a/src/Tablebot/Handler.hs b/src/Tablebot/Handler.hs index 8dbb004c..d4848578 100644 --- a/src/Tablebot/Handler.hs +++ b/src/Tablebot/Handler.hs @@ -13,33 +13,40 @@ module Tablebot.Handler ( eventHandler, runCron, killCron, + submitApplicationCommands, ) where -import Control.Concurrent (MVar) -import Control.Monad (unless) -import Control.Monad.Exception +import Control.Concurrent (MVar, putMVar, takeMVar) +import Control.Monad (unless, void) +import Control.Monad.Exception (MonadException (catch)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (ReaderT, ask, lift, runReaderT) +import Data.Bifunctor (Bifunctor (second)) +import Data.Map as M (fromList) import Data.Pool (Pool) import Data.Text (Text) import Database.Persist.Sqlite (SqlBackend, runSqlPool) -import Discord (DiscordHandler) +import Discord (Cache (cacheApplication), DiscordHandler, readCache, restCall) +import Discord.Interactions (ApplicationCommand (..), Interaction (..)) +import Discord.Requests (ChannelRequest (JoinThread)) import Discord.Types -import Tablebot.Internal.Handler.Command - ( parseNewMessage, - ) +import System.Environment (lookupEnv) +import Tablebot.Internal.Handler.Command (parseNewMessage) import Tablebot.Internal.Handler.Event - ( parseMessageChange, + ( parseApplicationCommandRecv, + parseComponentRecv, + parseMessageChange, parseOther, parseReactionAdd, parseReactionDel, ) import Tablebot.Internal.Plugins (changeAction) import Tablebot.Internal.Types -import Tablebot.Utility.Discord (sendEmbedMessage) -import Tablebot.Utility.Exception -import Tablebot.Utility.Types (TablebotCache) +import Tablebot.Utility.Discord (createApplicationCommand, interactionResponseCustomMessage, removeApplicationCommandsNotInList, sendChannelEmbedMessage) +import Tablebot.Utility.Exception (BotException, embedError) +import Tablebot.Utility.Types (MessageDetails (messageDetailsEmbeds), TablebotCache (cacheApplicationCommands), liftDiscord, messageDetailsBasic) +import Text.Read (readMaybe) import UnliftIO.Concurrent ( ThreadId, forkIO, @@ -55,7 +62,7 @@ import UnliftIO.Exception (catchAny) eventHandler :: PluginActions -> Text -> Event -> CompiledDatabaseDiscord () eventHandler pl prefix = \case MessageCreate m -> - ifNotBot m $ parseNewMessage pl prefix m `catch` \e -> changeAction () . sendEmbedMessage m "" $ embedError (e :: BotException) + ifNotBot m $ catchErrors (messageChannelId m) $ parseNewMessage pl prefix m MessageUpdate cid mid -> parseMessageChange (compiledOnMessageChanges pl) True cid mid MessageDelete cid mid -> @@ -69,9 +76,16 @@ eventHandler pl prefix = \case -- Similar with MessageReactionRemoveEmoji (removes all of one type). MessageReactionRemoveAll _cid _mid -> pure () MessageReactionRemoveEmoji _rri -> pure () + InteractionCreate i@InteractionComponent {} -> parseComponentRecv (compiledOnComponentRecvs pl) i `interactionErrorCatch` i + InteractionCreate i@InteractionApplicationCommand {} -> parseApplicationCommandRecv i `interactionErrorCatch` i + InteractionCreate i@InteractionApplicationCommandAutocomplete {} -> parseApplicationCommandRecv i `interactionErrorCatch` i + -- TODO: add application command autocomplete as an option + ThreadCreate c -> changeAction () $ void $ liftDiscord $ restCall $ JoinThread (channelId c) e -> parseOther (compiledOtherEvents pl) e where ifNotBot m = unless (userIsBot (messageAuthor m)) + interactionErrorCatch action i = action `catch` (\e -> changeAction () . interactionResponseCustomMessage i $ (messageDetailsBasic "") {messageDetailsEmbeds = Just [embedError (e :: BotException)]}) + catchErrors m = (`catch` (\e -> changeAction () . sendChannelEmbedMessage m "" $ embedError (e :: BotException))) -- | @runCron@ takes an individual @CronJob@ and runs it in a separate thread. -- The @ThreadId@ is returned so it can be killed later. @@ -99,3 +113,33 @@ runCron pool (CCronJob delay fn) = do -- | @killCron@ takes a list of @ThreadId@ and kills each thread. killCron :: [ThreadId] -> IO () killCron = mapM_ killThread + +-- | Given a list of compiled application commands and a pointer to the +-- tablebot cache, create the given application commands, purge ones that +-- weren't created by us, and place the application command id's and their +-- actions in the cache. +submitApplicationCommands :: [CompiledApplicationCommand] -> MVar TablebotCache -> DiscordHandler () +submitApplicationCommands compiledAppComms cacheMVar = + ( do + -- generate the application commands, cleaning up any application commands we don't like + serverIdStr' <- liftIO $ lookupEnv "SERVER_ID" + case serverIdStr' of + Nothing -> pure () + Just serverIdStr -> do + serverId <- readServerStr serverIdStr + aid <- partialApplicationID . cacheApplication <$> readCache + applicationCommands <- + mapM + ( \(CApplicationCommand cac action) -> do + ac <- createApplicationCommand aid serverId cac + return (applicationCommandId ac, action) + ) + compiledAppComms + removeApplicationCommandsNotInList aid serverId (fst <$> applicationCommands) + liftIO $ takeMVar cacheMVar >>= \tcache -> putMVar cacheMVar $ tcache {cacheApplicationCommands = M.fromList (second (lift .) <$> applicationCommands)} + ) + `catch` \(e :: IOError) -> liftIO $ putStrLn $ "There was an error of some sort when submitting the application commands - verify that `SERVER_ID` is set properly. (" <> show e <> ")" + where + readServerStr :: String -> DiscordHandler (Maybe GuildId) + readServerStr "global" = return Nothing + readServerStr s = maybe (fail $ "could not read server id: " <> show s) (return . Just) (readMaybe s) diff --git a/src/Tablebot/Internal/Administration.hs b/src/Tablebot/Internal/Administration.hs index ed5319e1..7d5ba552 100644 --- a/src/Tablebot/Internal/Administration.hs +++ b/src/Tablebot/Internal/Administration.hs @@ -14,11 +14,11 @@ module Tablebot.Internal.Administration ) where -import Control.Monad.Cont (void, when) +import Control.Monad.Cont (MonadIO, void, when) import Data.List.Extra (isInfixOf, lower, trim) import Data.Text (Text, pack) import Database.Persist -import Database.Persist.Sqlite (SqlPersistM) +import Database.Persist.Sqlite (SqlPersistT) import Database.Persist.TH import System.Environment (lookupEnv) import System.Process @@ -32,7 +32,7 @@ PluginBlacklist deriving Show |] -currentBlacklist :: SqlPersistM [Text] +currentBlacklist :: MonadIO m => SqlPersistT m [Text] currentBlacklist = do bl <- selectList allBlacklisted [] return $ fmap (pack . pluginBlacklistLabel . entityVal) bl @@ -61,22 +61,26 @@ restartIsTerminal :: ShutdownReason -> Bool restartIsTerminal Reload = False restartIsTerminal _ = True +gitUpdateEnabled :: IO Bool +gitUpdateEnabled = do + maybeEnabled <- lookupEnv "ALLOW_GIT_UPDATE" + return $ maybe False ((== "true") . lower . trim) maybeEnabled + updateGit :: IO () updateGit = do - maybeEnabled <- lookupEnv "ALLOW_GIT_UPDATE" - let enabled = maybe False ((== "true") . lower . trim) maybeEnabled + enabled <- gitUpdateEnabled when enabled $ do status <- readProcess "git" ["status"] "" let pattern :: String pattern = "working tree clean" clean :: Bool - clean = isInfixOf pattern status + clean = pattern `isInfixOf` status if clean then do callProcess "git" ["pull", "--rebase"] pullStatus <- readProcess "git" ["status"] "" let pullClean :: Bool - pullClean = isInfixOf pattern pullStatus + pullClean = pattern `isInfixOf` pullStatus if pullClean then putStrLn "Git pulled successfully. Restarting" else do @@ -85,4 +89,4 @@ updateGit = do else putStrLn "Git directory not clean. Not updating" gitVersion :: IO Text -gitVersion = (pack . trim) <$> readProcess "git" ["rev-parse", "HEAD"] "" +gitVersion = pack . trim <$> readProcess "git" ["rev-parse", "HEAD"] "" diff --git a/src/Tablebot/Internal/Alias.hs b/src/Tablebot/Internal/Alias.hs new file mode 100644 index 00000000..7782c701 --- /dev/null +++ b/src/Tablebot/Internal/Alias.hs @@ -0,0 +1,42 @@ +-- | +-- Module : Tablebot.Internal.Alias +-- Description : Alias management +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Alias management +module Tablebot.Internal.Alias where + +import Control.Monad.Exception (MonadException (catch), SomeException) +import Data.Text +import Database.Persist.Sqlite (BackendKey (SqlBackendKey)) +import qualified Database.Persist.Sqlite as Sql +import Database.Persist.TH +import Discord.Types +import Tablebot.Internal.Administration (currentBlacklist) +import Tablebot.Internal.Types +import Tablebot.Utility.Database (liftSql, selectList) +import Tablebot.Utility.Types (EnvDatabaseDiscord) + +share + [mkPersist sqlSettings, mkMigrate "aliasMigration"] + [persistLowerCase| +Alias + alias Text + command Text + type AliasType + UniqueAlias alias type + deriving Show + deriving Eq +|] + +getAliases :: UserId -> EnvDatabaseDiscord d (Maybe [Alias]) +getAliases uid = do + blacklist <- liftSql currentBlacklist + if "alias" `elem` blacklist + then return Nothing + else + (Just . fmap Sql.entityVal <$> selectList [AliasType Sql.<-. [AliasPublic, AliasPrivate uid]] []) + `catch` (\(_ :: SomeException) -> return Nothing) diff --git a/src/Tablebot/Internal/Embed.hs b/src/Tablebot/Internal/Embed.hs index e533b2bd..d8109f9e 100644 --- a/src/Tablebot/Internal/Embed.hs +++ b/src/Tablebot/Internal/Embed.hs @@ -9,84 +9,14 @@ -- This module contains some behind the scenes logic to allow creation of coloured embeds module Tablebot.Internal.Embed where -import Data.Aeson -import qualified Data.ByteString.Lazy as BL import Data.Text (Text) -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types -import Network.HTTP.Client.MultipartFormData (partBS) -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import Tablebot.Utility.Types - -colourToInternal :: DiscordColour -> Integer -colourToInternal (RGB r g b) = ((r * 256) + g) * 256 + b -colourToInternal Default = 0 -colourToInternal Aqua = 1752220 -colourToInternal DarkAqua = 1146986 -colourToInternal Green = 3066993 -colourToInternal DarkGreen = 2067276 -colourToInternal Blue = 3447003 -colourToInternal DarkBlue = 2123412 -colourToInternal Purple = 10181046 -colourToInternal DarkPurple = 7419530 -colourToInternal LuminousVividPink = 15277667 -colourToInternal DarkVividPink = 11342935 -colourToInternal Gold = 15844367 -colourToInternal DarkGold = 12745742 -colourToInternal Orange = 15105570 -colourToInternal DarkOrange = 11027200 -colourToInternal Red = 15158332 -colourToInternal DarkRed = 10038562 -colourToInternal Gray = 9807270 -colourToInternal DarkGray = 9936031 -colourToInternal DarkerGray = 8359053 -colourToInternal LightGray = 12370112 -colourToInternal Navy = 3426654 -colourToInternal DarkNavy = 2899536 -colourToInternal Yellow = 16776960 -colourToInternal DiscordWhite = 16777215 -colourToInternal DiscordBlurple = 5793266 -colourToInternal DiscordGrayple = 10070709 -colourToInternal DiscordDarkButNotBlack = 2895667 -colourToInternal DiscordNotQuiteBlack = 2303786 -colourToInternal DiscordGreen = 5763719 -colourToInternal DiscordYellow = 16705372 -colourToInternal DiscordFuschia = 15418782 -colourToInternal DiscordRed = 15548997 -colourToInternal DiscordBlack = 16777215 - --- | TablebotEmbedRequest is a request object that mimics various bits of the discord api, just so we can add colours. --- This is *really* janky. The library exposes *no way* to create a coloured embed through its main api, --- so I'm having to manually reimplement the sending logic just to add this in. --- If you suffer from nightmares, don't look in 'Tablebot.Handler.Embed'. Nothing good lives there. --- In the future, I may actually submit a PR to discord-haskell with a fix to allow colours properly. -channels :: R.Url 'R.Https -channels = baseUrl /: "channels" - -data TablebotEmbedRequest a where TablebotEmbedRequest :: ChannelId -> Text -> Embed -> TablebotEmbedRequest Message - -instance Request (TablebotEmbedRequest a) where - jsonRequest = createEmbedJson - majorRoute = embedMajorRoute - -embedMajorRoute :: TablebotEmbedRequest a -> String -embedMajorRoute (TablebotEmbedRequest chan _ _) = "msg " <> show chan - -createEmbedJson :: TablebotEmbedRequest a -> JsonRequest -createEmbedJson (TablebotEmbedRequest chan msg embed) = - let partJson = partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["content" .= msg, "embed" .= embed] - body = R.reqBodyMultipart [partJson] - in Post (channels // chan /: "messages") body mempty +import Discord.Internal.Types (CreateEmbed (CreateEmbed)) class Embeddable e where - asEmbed :: e -> Embed - -instance Embeddable Embed where - asEmbed = id + asEmbed :: e -> CreateEmbed instance Embeddable CreateEmbed where - asEmbed = createEmbed + asEmbed = id instance Embeddable Text where - asEmbed t = createEmbed $ CreateEmbed "" "" Nothing "" "" Nothing t [] Nothing "" Nothing Nothing + asEmbed t = CreateEmbed "" "" Nothing "" "" Nothing t [] Nothing "" Nothing Nothing Nothing diff --git a/src/Tablebot/Internal/Handler/Command.hs b/src/Tablebot/Internal/Handler/Command.hs index 4e7575ce..2adc979a 100644 --- a/src/Tablebot/Internal/Handler/Command.hs +++ b/src/Tablebot/Internal/Handler/Command.hs @@ -13,21 +13,25 @@ module Tablebot.Internal.Handler.Command ( parseNewMessage, parseCommands, parseInlineCommands, + parseValue, ) where +import Data.List (find) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes) import Data.Set (singleton, toList) import Data.Text (Text) +import qualified Data.Text as T import Data.Void (Void) -import Discord.Types (Message (messageText)) +import Discord.Types (Message (messageAuthor, messageContent), User (userId)) +import Tablebot.Internal.Alias import Tablebot.Internal.Plugins (changeAction) import Tablebot.Internal.Types import Tablebot.Utility.Discord (sendEmbedMessage) -import Tablebot.Utility.Exception (BotException (ParserException), embedError) +import Tablebot.Utility.Exception (BotException (ParserException), embedError, throwBot) import Tablebot.Utility.Parser (skipSpace1, space, word) -import Tablebot.Utility.Types (Parser) +import Tablebot.Utility.Types (EnvDatabaseDiscord, Parser) import Text.Megaparsec import qualified UnliftIO.Exception as UIOE (tryAny) @@ -36,7 +40,7 @@ import qualified UnliftIO.Exception as UIOE (tryAny) -- to find inline commands. parseNewMessage :: PluginActions -> Text -> Message -> CompiledDatabaseDiscord () parseNewMessage pl prefix m = - if isCommandCall $ messageText m + if isCommandCall $ messageContent m then parseCommands (compiledCommands pl) m prefix else parseInlineCommands (compiledInlineCommands pl) m where @@ -49,6 +53,14 @@ parseNewMessage pl prefix m = checkCommand :: Parser () checkCommand = chunk prefix *> word *> (space <|> eof) +parseCommands :: [CompiledCommand] -> Message -> Text -> CompiledDatabaseDiscord () +parseCommands cs m prefix = do + as <- changeAction () $ getAliases (userId $ messageAuthor m) + res <- parseCommands' cs as m prefix + case res of + Right _ -> return () + Left (title, e) -> changeAction () . sendEmbedMessage m "" $ embedError $ ParserException (T.unpack title) . T.unpack $ "```\n" <> e <> "```" + -- | Given a list of 'Command' @cs@, the 'Message' that triggered the event -- @m@, and a command prefix @prefix@, construct a parser that parses commands. -- We look for the prefix, followed by trying out the name of each command, @@ -57,20 +69,44 @@ parseNewMessage pl prefix m = -- -- If the parser errors, the last error (which is hopefully one created by -- '') is sent to the user as a Discord message. -parseCommands :: [CompiledCommand] -> Message -> Text -> CompiledDatabaseDiscord () -parseCommands cs m prefix = case parse (parser cs) "" (messageText m) of - Right p -> p m - Left e -> - let (errs, title) = makeBundleReadable e - in changeAction () . sendEmbedMessage m "" $ embedError $ ParserException title $ "```\n" ++ errorBundlePretty errs ++ "```" +parseCommands' :: [CompiledCommand] -> Maybe [Alias] -> Message -> Text -> CompiledDatabaseDiscord (Either (Text, Text) ()) +parseCommands' cs as m prefix = case parse (parser cs) "" (messageContent m) of + Right p -> Right <$> p m + Left e -> case as of + (Just as'@(_ : _)) -> + case parse (aliasParser as') "" (messageContent m) of + -- if the alias parser fails, just give the outer error + Left _ -> mkTitleBody e + -- if we get a valid alias, run the command with the alias + -- the way we do this is by running this function again and edit the + -- message text to be the alias's command + -- we ensure no infinite loops by removing the alias we just used + Right (a', rest) -> do + recur <- parseCommands' cs (Just $ filter (/= a') as') (m {messageContent = prefix <> aliasCommand a' <> rest}) prefix + -- if successful, return the result. if not, edit the error we + -- obtained from running the alias to include the alias we tried to + -- use + case recur of + Right _ -> return recur + Left (title, err) -> return $ Left (title, aliasAlias a' <> " -> " <> aliasCommand a' <> "\n" <> err) + _ -> mkTitleBody e where + mkTitleBody e' = let (errs, title) = makeBundleReadable e' in return $ Left (T.pack title, T.pack $ errorBundlePretty errs) parser :: [CompiledCommand] -> Parser (Message -> CompiledDatabaseDiscord ()) parser cs' = do _ <- chunk prefix - choice (map toErroringParser cs') "No command with that name was found!" - toErroringParser :: CompiledCommand -> Parser (Message -> CompiledDatabaseDiscord ()) - toErroringParser c = try (chunk $ commandName c) *> (skipSpace1 <|> eof) *> (try (choice $ map toErroringParser $ commandSubcommands c) <|> commandParser c) + choice (map commandToParser cs') "No command with that name was found!" + commandToParser :: CompiledCommand -> Parser (Message -> CompiledDatabaseDiscord ()) + commandToParser c = try (chunk (commandName c) *> (skipSpace1 <|> eof)) *> (try (choice $ map commandToParser $ commandSubcommands c) <|> commandParser c) + aliasParser :: [Alias] -> Parser (Alias, Text) + aliasParser as' = do + _ <- chunk prefix + a <- choice (map (chunk . aliasAlias) as') "No command with that name was found!" + rst <- many anySingle + case find (\a' -> aliasAlias a' == a) as' of + Just a' -> return (a', T.pack rst) + Nothing -> fail "This should never happen! (aliasParser)" data ReadableError = UnknownError | KnownError String [String] deriving (Show, Eq, Ord) @@ -123,7 +159,15 @@ makeReadable e = (mapParseError (const UnknownError) e, Nothing) -- command's parser on the message text. Errors are not sent to the user, and do -- not halt command attempts (achieved using 'tryAny'). parseInlineCommands :: [CompiledInlineCommand] -> Message -> CompiledDatabaseDiscord () -parseInlineCommands cs m = mapM_ (fromResult . (\cic -> parse (inlineCommandParser cic) "" (messageText m))) cs +parseInlineCommands cs m = mapM_ (fromResult . (\cic -> parse (inlineCommandParser cic) "" (messageContent m))) cs where fromResult (Right p) = UIOE.tryAny (p m) fromResult _ = return $ return () + +-- | Turn the parsing of a value into an exception when given text to parse. +parseValue :: Parser a -> Text -> EnvDatabaseDiscord s a +parseValue par t = case parse par "" t of + Right p -> return p + Left e -> + let (errs, title) = makeBundleReadable e + in throwBot $ ParserException title $ "```\n" ++ errorBundlePretty errs ++ "```" diff --git a/src/Tablebot/Internal/Handler/Event.hs b/src/Tablebot/Internal/Handler/Event.hs index 33cbfbe1..9ada3821 100644 --- a/src/Tablebot/Internal/Handler/Event.hs +++ b/src/Tablebot/Internal/Handler/Event.hs @@ -12,12 +12,22 @@ module Tablebot.Internal.Handler.Event ( parseMessageChange, parseReactionAdd, parseReactionDel, + parseComponentRecv, + parseApplicationCommandRecv, parseOther, ) where +import Control.Concurrent (readMVar) +import Control.Monad.RWS (MonadIO (liftIO), MonadReader (ask)) +import qualified Data.Map as M +import Data.Text as T (drop, isPrefixOf, length) +import Discord.Interactions (ApplicationCommandData (applicationCommandDataId), ComponentData (componentDataCustomId), Interaction (..)) import Discord.Types (ChannelId, Event, MessageId, ReactionInfo) -import Tablebot.Internal.Types +import Tablebot.Internal.Plugins (changeAction) +import Tablebot.Internal.Types as IT +import Tablebot.Utility.Exception (BotException (InteractionException), throwBot) +import qualified Tablebot.Utility.Types as UT -- | This runs each 'MessageChange' feature in @cs@ with the information from a -- Discord 'MessageUpdate' or 'MessageDelete' event - whether it is an update @@ -47,6 +57,35 @@ parseReactionDel cs info = mapM_ doReactionAdd cs where doReactionAdd c = onReactionDelete c info +-- | When given the compiled component recv actions and a component interaction, +-- find and run the correct action. +parseComponentRecv :: [CompiledComponentRecv] -> Interaction -> CompiledDatabaseDiscord () +parseComponentRecv cs info@InteractionComponent {componentData = idc} = mapM_ removePrefix cs' + where + getPrefix ccr = componentPluginName ccr <> " " <> componentName ccr + cs' = filter (\ccr -> getPrefix ccr `isPrefixOf` componentDataCustomId idc) cs + removePrefix ccr = ccr `onComponentRecv` (info {componentData = (idc {componentDataCustomId = T.drop (T.length (getPrefix ccr)) (componentDataCustomId idc)})}) +parseComponentRecv _ _ = return () + +-- | When given an application command interaction, find and run the correct +-- action. +parseApplicationCommandRecv :: Interaction -> CompiledDatabaseDiscord () +parseApplicationCommandRecv info@InteractionApplicationCommand {applicationCommandData = idac} = do + tvar <- ask + cache <- liftIO $ readMVar tvar + let action = UT.cacheApplicationCommands cache M.!? applicationCommandDataId idac + case action of + Nothing -> throwBot $ InteractionException "could not find the given application command" + Just act -> changeAction () $ act info +parseApplicationCommandRecv info@InteractionApplicationCommandAutocomplete {applicationCommandData = idac} = do + tvar <- ask + cache <- liftIO $ readMVar tvar + let action = UT.cacheApplicationCommands cache M.!? applicationCommandDataId idac + case action of + Nothing -> throwBot $ InteractionException "could not find the given application command" + Just act -> changeAction () $ act info +parseApplicationCommandRecv _ = return () + -- | This runs each 'Other' feature in @cs@ with the Discord 'Event' provided. -- Note that any events covered by other feature types will /not/ be run -- through this. diff --git a/src/Tablebot/Internal/Permission.hs b/src/Tablebot/Internal/Permission.hs index ef266be9..0bc498ca 100644 --- a/src/Tablebot/Internal/Permission.hs +++ b/src/Tablebot/Internal/Permission.hs @@ -10,9 +10,8 @@ module Tablebot.Internal.Permission where import Control.Monad.IO.Class (liftIO) -import Discord.Types (GuildMember, Message, RoleId, memberRoles) +import Discord.Types (GuildMember, RoleId, memberRoles) import System.Environment (lookupEnv) -import Tablebot.Utility.Discord (getMessageMember) import Tablebot.Utility.Types import Tablebot.Utility.Utils (isDebug) import Text.Read (readMaybe) @@ -57,9 +56,16 @@ permsFromGroups debug krls gps = elemish (Just a) b = a `elem` b elemish Nothing _ = False -getSenderPermission :: Message -> EnvDatabaseDiscord s UserPermission +-- getSenderPermission :: Message -> EnvDatabaseDiscord s UserPermission +-- getSenderPermission m = do +-- member <- getMessageMember m +-- knownroles <- liftIO getKnownRoles +-- debug <- liftIO isDebug +-- return $ permsFromGroups debug knownroles $ getMemberGroups member + +getSenderPermission :: Context m => m -> EnvDatabaseDiscord s UserPermission getSenderPermission m = do - member <- getMessageMember m + let member = contextMember m knownroles <- liftIO getKnownRoles debug <- liftIO isDebug return $ permsFromGroups debug knownroles $ getMemberGroups member diff --git a/src/Tablebot/Internal/Plugins.hs b/src/Tablebot/Internal/Plugins.hs index 88fe25e0..a6747ab8 100644 --- a/src/Tablebot/Internal/Plugins.hs +++ b/src/Tablebot/Internal/Plugins.hs @@ -9,43 +9,45 @@ -- This contains some functions to combine and compile plugins module Tablebot.Internal.Plugins where -import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Reader (ReaderT (runReaderT)) +import Data.Default (Default (def)) import Discord.Types (Message) import Tablebot.Internal.Types hiding (helpPages, migrations) -import qualified Tablebot.Internal.Types as HT -import Tablebot.Utility.Types +import qualified Tablebot.Internal.Types as IT +import Tablebot.Utility.Types as UT -- | Combines a list of plugins into a single plugin with the combined -- functionality. The bot actually runs a single plugin, which is just the -- combined version of all input plugins. combinePlugins :: [CompiledPlugin] -> CombinedPlugin -combinePlugins [] = CmPl [] [] [] +combinePlugins [] = def combinePlugins (p : ps) = let p' = combinePlugins ps in CmPl { combinedSetupAction = setupAction p : combinedSetupAction p', - combinedMigrations = HT.migrations p ++ combinedMigrations p', - combinedHelpPages = HT.helpPages p ++ combinedHelpPages p' + combinedMigrations = IT.migrations p ++ combinedMigrations p', + combinedHelpPages = IT.helpPages p ++ combinedHelpPages p' } -- | Combines a list of plugins actions into a single pa with the combined -- functionality. combineActions :: [PluginActions] -> PluginActions -combineActions [] = PA [] [] [] [] [] [] [] +combineActions [] = def combineActions (p : ps) = let p' = combineActions ps in PA - { compiledCommands = compiledCommands p +++ compiledCommands p', + { compiledApplicationCommands = compiledApplicationCommands p +++ compiledApplicationCommands p', + compiledCommands = compiledCommands p +++ compiledCommands p', compiledInlineCommands = compiledInlineCommands p +++ compiledInlineCommands p', compiledOnMessageChanges = compiledOnMessageChanges p +++ compiledOnMessageChanges p', compiledOnReactionAdds = compiledOnReactionAdds p +++ compiledOnReactionAdds p', compiledOnReactionDeletes = compiledOnReactionDeletes p +++ compiledOnReactionDeletes p', + compiledOnComponentRecvs = compiledOnComponentRecvs p +++ compiledOnComponentRecvs p', compiledOtherEvents = compiledOtherEvents p +++ compiledOtherEvents p', compiledCronJobs = compiledCronJobs p +++ compiledCronJobs p' } where -- copy across Finnbar's +++ optimisation for empty lists from the old system, as it applies here. - [] +++ [] = [] a +++ [] = a [] +++ a = a a +++ b = a ++ b @@ -59,20 +61,24 @@ compilePlugin p = CPl (pluginName p) sa (helpPages p) (migrations p) return $ PA + (map (fixApplicationCommand state) $ applicationCommands p) (map (fixCommand state) $ commands p) (map (fixInlineCommand state) $ inlineCommands p) (map (fixOnMessageChanges state) $ onMessageChanges p) (map (fixOnReactionAdd state) $ onReactionAdds p) (map (fixOnReactionDelete state) $ onReactionDeletes p) + (map (fixOnComponentRecv state) $ onComponentRecvs p) (map (fixOther state) $ otherEvents p) (map (fixCron state) $ cronJobs p) -- Command converters + fixApplicationCommand state' (ApplicationCommandRecv cac action') = CApplicationCommand cac (changeAction state' . action') fixCommand state' (Command name' action' subcommands') = CCommand name' (compileParser state' action') (map (fixCommand state') subcommands') fixInlineCommand state' (InlineCommand action') = CInlineCommand (compileParser state' action') fixOnMessageChanges state' (MessageChange action') = CMessageChange (((changeAction state' .) .) . action') fixOnReactionAdd state' (ReactionAdd action') = CReactionAdd (changeAction state' . action') fixOnReactionDelete state' (ReactionDel action') = CReactionDel (changeAction state' . action') + fixOnComponentRecv state' (ComponentRecv name' action') = CComponentRecv (pluginName p) name' (changeAction state' . action') fixOther state' (Other action') = COther (changeAction state' . action') fixCron state' (CronJob time action') = CCronJob time (changeAction state' action') @@ -82,7 +88,10 @@ compileParser :: s -> Parser (Message -> EnvDatabaseDiscord s a) -> Parser (Mess compileParser s = fmap (changeMessageAction s) changeMessageAction :: s -> (Message -> EnvDatabaseDiscord s a) -> Message -> CompiledDatabaseDiscord a -changeMessageAction s action message = runReaderT (action message) s +changeMessageAction = changeAnyAction + +changeAnyAction :: s -> (m -> EnvDatabaseDiscord s a) -> m -> CompiledDatabaseDiscord a +changeAnyAction s action m = changeAction s (action m) changeAction :: s -> EnvDatabaseDiscord s a -> CompiledDatabaseDiscord a changeAction s action = runReaderT action s diff --git a/src/Tablebot/Internal/Types.hs b/src/Tablebot/Internal/Types.hs index c8780087..7a430e13 100644 --- a/src/Tablebot/Internal/Types.hs +++ b/src/Tablebot/Internal/Types.hs @@ -13,9 +13,11 @@ module Tablebot.Internal.Types where import Control.Concurrent.MVar (MVar) import Control.Monad.Reader (ReaderT) +import Data.Default (Default) import Data.Text (Text) -import Database.Persist.Sqlite (Migration, SqlPersistT) +import Database.Persist.Sqlite import Discord +import Discord.Interactions (CreateApplicationCommand, Interaction) import Discord.Types import Tablebot.Utility.Types @@ -32,25 +34,38 @@ data CompiledPlugin = CPl } data PluginActions = PA - { compiledCommands :: [CompiledCommand], + { compiledApplicationCommands :: [CompiledApplicationCommand], + compiledCommands :: [CompiledCommand], compiledInlineCommands :: [CompiledInlineCommand], compiledOnMessageChanges :: [CompiledMessageChange], compiledOnReactionAdds :: [CompiledReactionAdd], compiledOnReactionDeletes :: [CompiledReactionDel], + compiledOnComponentRecvs :: [CompiledComponentRecv], compiledOtherEvents :: [CompiledOther], compiledCronJobs :: [CompiledCronJob] } +instance Default PluginActions where + def = PA [] [] [] [] [] [] [] [] [] + data CombinedPlugin = CmPl { combinedSetupAction :: [Database PluginActions], combinedHelpPages :: [HelpPage], combinedMigrations :: [Migration] } +instance Default CombinedPlugin where + def = CmPl [] [] [] + -- * Compiled Items -- These are compiled forms of the actions from the public types that remove the reader. +data CompiledApplicationCommand = CApplicationCommand + { applicationCommand :: CreateApplicationCommand, + applicationCommandAction :: Interaction -> CompiledDatabaseDiscord () + } + data CompiledCommand = CCommand { commandName :: Text, commandParser :: Parser (Message -> CompiledDatabaseDiscord ()), @@ -73,6 +88,12 @@ newtype CompiledReactionDel = CReactionDel { onReactionDelete :: ReactionInfo -> CompiledDatabaseDiscord () } +data CompiledComponentRecv = CComponentRecv + { componentPluginName :: Text, + componentName :: Text, + onComponentRecv :: Interaction -> CompiledDatabaseDiscord () + } + newtype CompiledOther = COther { onOtherEvent :: Event -> CompiledDatabaseDiscord () } @@ -81,3 +102,33 @@ data CompiledCronJob = CCronJob { timeframe :: Int, onCron :: CompiledDatabaseDiscord () } + +-- * Configuration type + +-- Allows others to configure the bot. + +data BotConfig = BotConfig + { rootHelpText :: Text, + gamePlaying :: Text -> Text + } + +instance Default BotConfig where + def = + BotConfig + { rootHelpText = "This bot is built off the Tablebot framework ().", + gamePlaying = const "Kirby: Planet Robobot" + } + +data AliasType = AliasPublic | AliasPrivate UserId + deriving (Eq, Show, Ord) + +instance PersistField AliasType where + toPersistValue (AliasPrivate (DiscordId (Snowflake wd))) = PersistInt64 (fromIntegral wd) + toPersistValue AliasPublic = PersistInt64 (-1) + fromPersistValue = \case + PersistInt64 (-1) -> Right AliasPublic + PersistInt64 i -> Right $ AliasPrivate (fromIntegral i) + _ -> Left "AliasType: fromPersistValue: Invalid value" + +instance PersistFieldSql AliasType where + sqlType _ = SqlInt64 diff --git a/src/Tablebot/Plugins.hs b/src/Tablebot/Plugins.hs index 56e72e3b..95b9014a 100644 --- a/src/Tablebot/Plugins.hs +++ b/src/Tablebot/Plugins.hs @@ -9,52 +9,54 @@ -- Here is a collection of existing plugins for Tablebot. If you add new plugins -- to the Plugins directory, include an import here. This means that users only -- need to import @Tablebot.Plugins@ to import individual plugins. -module Tablebot.Plugins - ( plugins, - ) -where +module Tablebot.Plugins where import Control.Concurrent.MVar (MVar) +import Data.Text (Text) import Tablebot.Internal.Administration (ShutdownReason) import Tablebot.Internal.Plugins (compilePlugin) -import Tablebot.Internal.Types (CompiledPlugin) +import Tablebot.Internal.Types (CompiledPlugin (..)) import Tablebot.Plugins.Administration (administrationPlugin) -import Tablebot.Plugins.Basic (basicPlugin) -import Tablebot.Plugins.Cats (catPlugin) -import Tablebot.Plugins.Dogs (dogPlugin) -import Tablebot.Plugins.Flip (flipPlugin) -import Tablebot.Plugins.Fox (foxPlugin) -import Tablebot.Plugins.Netrunner (netrunnerPlugin) -import Tablebot.Plugins.Ping (pingPlugin) -import Tablebot.Plugins.Quote (quotePlugin) -import Tablebot.Plugins.Reminder (reminderPlugin) -import Tablebot.Plugins.Roll (rollPlugin) -import Tablebot.Plugins.Say (sayPlugin) -import Tablebot.Plugins.Shibe (shibePlugin) -import Tablebot.Plugins.Suggest (suggestPlugin) -import Tablebot.Plugins.Welcome (welcomePlugin) +import Tablebot.Plugins.Alias (alias) +import Tablebot.Plugins.Basic (basic) +import Tablebot.Plugins.Cats (cat) +import Tablebot.Plugins.Dogs (dog) +import Tablebot.Plugins.Flip (flips) +import Tablebot.Plugins.Fox (fox) +import Tablebot.Plugins.Netrunner (netrunner) +import Tablebot.Plugins.Ping (pingpong) +import Tablebot.Plugins.Quote (quotes) +import Tablebot.Plugins.Reminder (reminder) +import Tablebot.Plugins.Roll (roll) +import Tablebot.Plugins.Say (says) +import Tablebot.Plugins.Shibe (shibe) +import Tablebot.Plugins.Suggest (suggests) +import Tablebot.Plugins.Welcome (welcome) -- Use long list format to make additions and removals non-conflicting on git PRs -plugins :: MVar ShutdownReason -> [CompiledPlugin] -plugins rFlag = - addAdministrationPlugin - rFlag - [ compilePlugin pingPlugin, - compilePlugin basicPlugin, - compilePlugin catPlugin, - compilePlugin dogPlugin, - compilePlugin shibePlugin, - compilePlugin flipPlugin, - compilePlugin foxPlugin, - compilePlugin netrunnerPlugin, - compilePlugin quotePlugin, - compilePlugin reminderPlugin, - compilePlugin sayPlugin, - compilePlugin suggestPlugin, - compilePlugin rollPlugin, - compilePlugin welcomePlugin - ] +allPlugins :: [CompiledPlugin] +allPlugins = + [ pingpong, + alias, + basic, + cat, + dog, + shibe, + flips, + fox, + netrunner, + quotes, + reminder, + says, + suggests, + roll, + welcome + ] -- | @addAdministrationPlugin@ is needed to allow the administration plugin to be aware of the list of current plugins addAdministrationPlugin :: MVar ShutdownReason -> [CompiledPlugin] -> [CompiledPlugin] addAdministrationPlugin rFlag cps = compilePlugin (administrationPlugin rFlag cps) : cps + +-- | @plugs `minusPl` names@ removes all plugins with the given names. +minusPl :: [CompiledPlugin] -> [Text] -> [CompiledPlugin] +minusPl = foldr (\n plugs -> filter ((/= n) . compiledName) plugs) diff --git a/src/Tablebot/Plugins/Administration.hs b/src/Tablebot/Plugins/Administration.hs index c595a1cc..6de41e6c 100644 --- a/src/Tablebot/Plugins/Administration.hs +++ b/src/Tablebot/Plugins/Administration.hs @@ -52,14 +52,14 @@ blacklistComm :: EnvDatabaseDiscord SS () blacklistComm (WErr (Left (Left (_, pLabel)))) = addBlacklist pLabel blacklistComm (WErr (Left (Right (_, pLabel)))) = removeBlacklist pLabel -blacklistComm (WErr (Right (_))) = listBlacklist +blacklistComm (WErr (Right _)) = listBlacklist addBlacklist :: String -> Message -> EnvDatabaseDiscord SS () addBlacklist pLabel m = requirePermission Superuser m $ do known <- ask -- It's not an error to add an unknown plugin (so that you can pre-disable a plugin you know you're about to add), -- but emmit a warning so people know if it wasn't deliberate - when ((pack pLabel) `notElem` known) $ sendMessage m "Warning, unknown plugin" + when (pack pLabel `notElem` known) $ sendMessage m "Warning, unknown plugin" extant <- exists [PluginBlacklistLabel ==. pLabel] if not extant then do @@ -132,7 +132,7 @@ version = Command "version" noCommand [] gVersion <- getVersionInfo sendMessage m $ formatVersions gVersion formatVersions :: VersionInfo -> Text - formatVersions vi = "Tablebot version " <> (pack $ showVersion $ procVersion vi) <> "\nGit Hash: `" <> (gitHash vi) <> "`" + formatVersions vi = "Tablebot version " <> pack (showVersion $ procVersion vi) <> "\nGit Hash: `" <> gitHash vi <> "`" -- | @botcontrol@ reloads the bot with any new configuration changes. botControl :: MVar ShutdownReason -> EnvCommand SS @@ -144,13 +144,13 @@ botControl rFlag = Command "botcontrol" noCommand [reload rFlag, restart rFlag, -- | @reload@ reloads the bot with any new configuration changes. reload :: MVar ShutdownReason -> EnvCommand SS -reload rFlag = Command "reload" restartCommand [] +reload rFlag = Command "reload" reloadCommand [] where - restartCommand :: Parser (Message -> EnvDatabaseDiscord SS ()) - restartCommand = noArguments $ \m -> requirePermission Superuser m $ do + reloadCommand :: Parser (Message -> EnvDatabaseDiscord SS ()) + reloadCommand = noArguments $ \m -> requirePermission Superuser m $ do sendMessage m "Reloading bot..." _ <- liftIO $ swapMVar rFlag Reload - liftDiscord $ stopDiscord + liftDiscord stopDiscord -- | @reload@ reloads the bot with any new configuration changes. restart :: MVar ShutdownReason -> EnvCommand SS @@ -160,17 +160,17 @@ restart rFlag = Command "restart" restartCommand [] restartCommand = noArguments $ \m -> requirePermission Superuser m $ do sendMessage m "Restarting bot... (this may take some time)" _ <- liftIO $ swapMVar rFlag Restart - liftDiscord $ stopDiscord + liftDiscord stopDiscord -- | @halt@ stops the bot. halt :: MVar ShutdownReason -> EnvCommand SS -halt rFlag = Command "halt" restartCommand [] +halt rFlag = Command "halt" haltCommand [] where - restartCommand :: Parser (Message -> EnvDatabaseDiscord SS ()) - restartCommand = noArguments $ \m -> requirePermission Superuser m $ do + haltCommand :: Parser (Message -> EnvDatabaseDiscord SS ()) + haltCommand = noArguments $ \m -> requirePermission Superuser m $ do sendMessage m "Halting bot! (Goodnight, cruel world)" _ <- liftIO $ swapMVar rFlag Halt - liftDiscord $ stopDiscord + liftDiscord stopDiscord -- | @gitupdate@ pulls the latest version from the git. gitprompt :: MVar ShutdownReason -> EnvCommand SS @@ -181,13 +181,17 @@ gitprompt rFlag = Command "gitupdate" promptCommand [gitupdate rFlag] sendMessage m "Please confirm you want to do this by appending the following to your command:\n`yes I'm sure I want to do this and understand it's potentially dangerous`" gitupdate :: MVar ShutdownReason -> EnvCommand SS -gitupdate rFlag = Command "yes I'm sure I want to do this and understand it's potentially dangerous" restartCommand [] +gitupdate rFlag = Command "yes I'm sure I want to do this and understand it's potentially dangerous" updateCommand [] where - restartCommand :: Parser (Message -> EnvDatabaseDiscord SS ()) - restartCommand = noArguments $ \m -> requirePermission Superuser m $ do - sendMessage m "Attempting to update bot from the git. Please wait" - _ <- liftIO $ swapMVar rFlag GitUpdate - liftDiscord $ stopDiscord + updateCommand :: Parser (Message -> EnvDatabaseDiscord SS ()) + updateCommand = noArguments $ \m -> requirePermission Superuser m $ do + enabled <- liftIO gitUpdateEnabled + if not enabled + then sendMessage m "Git update is not enabled; set `ALLOW_GIT_UPDATE` to `true`." + else do + sendMessage m "Attempting to update bot from the git. Please wait" + _ <- liftIO $ swapMVar rFlag GitUpdate + liftDiscord stopDiscord versionHelp :: HelpPage versionHelp = diff --git a/src/Tablebot/Plugins/Alias.hs b/src/Tablebot/Plugins/Alias.hs new file mode 100644 index 00000000..d0cee7bd --- /dev/null +++ b/src/Tablebot/Plugins/Alias.hs @@ -0,0 +1,177 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +-- | +-- Module : Tablebot.Plugins.Alias +-- Description : Alias plugin +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Allows users to add, list, and delete aliases. +module Tablebot.Plugins.Alias (alias, Alias (..), getAliases) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Database.Persist.Sqlite as Sql +import Discord.Types +import Tablebot.Internal.Alias +import Tablebot.Internal.Types (AliasType (..)) +import Tablebot.Utility +import Tablebot.Utility.Database (deleteBy, exists) +import Tablebot.Utility.Discord (sendMessage) +import Tablebot.Utility.Permission (requirePermission) +import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (..), WithError (..)) +import Text.RawString.QQ (r) + +publicAliasPerms :: RequiredPermission +publicAliasPerms = Moderator + +alias :: CompiledPlugin +alias = compilePlugin aliasPlugin + +aliasTypeToText :: AliasType -> Text +aliasTypeToText AliasPublic = "Public" +aliasTypeToText (AliasPrivate _) = "Private" + +updateAlias :: Alias -> EnvDatabaseDiscord d (Sql.Entity Alias) +updateAlias a = liftSql $ Sql.upsertBy (UniqueAlias (aliasAlias a) (aliasType a)) a [AliasCommand Sql.=. aliasCommand a] + +aliasPlugin :: Plugin +aliasPlugin = + (plug "alias") + { commands = [aliasComm], + migrations = [aliasMigration], + helpPages = [aliasHelp] + } + +aliasComm :: Command +aliasComm = + Command + "alias" + (parseComm (\m -> aliasList (AliasPrivate (userId $ messageAuthor m)) m)) + [aliasAddCommand, aliasListCommand, aliasDeleteCommand, commandAlias "remove" aliasDeleteCommand] + +aliasHelp :: HelpPage +aliasHelp = + HelpPage + "alias" + [] + "alias a command to another command" + [r|**Aliases** +Allows creation, viewing, and deletion of aliases. +Calling without any arguments will show a list of aliases. + +*Usage:* `alias`|] + [aliasAddHelp, aliasListHelp, aliasDeleteHelp] + None + +aliasAddCommand :: Command +aliasAddCommand = + Command + "add" + (parseComm aliasAddPrivateComm) + [ Command "private" (parseComm aliasAddPrivateComm) [], + Command "public" (parseComm aliasAddPublicComm) [] + ] + where + aliasAddPrivateComm :: WithError "Need a single word" Text -> WithError "Need a quoted string" (Quoted Text) -> Message -> DatabaseDiscord () + aliasAddPrivateComm (WErr t) (WErr (Qu t')) m = aliasAdd t t' (AliasPrivate (userId $ messageAuthor m)) m + aliasAddPublicComm :: WithError "Need a single word" Text -> WithError "Need a quoted string" (Quoted Text) -> Message -> DatabaseDiscord () + aliasAddPublicComm (WErr t) (WErr (Qu t')) m = requirePermission publicAliasPerms m $ aliasAdd t t' AliasPublic m + +aliasAdd :: Text -> Text -> AliasType -> Message -> DatabaseDiscord () +aliasAdd a b at m = do + let new = Alias a b at + _ <- updateAlias new + sendMessage m ("Added " <> T.toLower (aliasTypeToText at) <> " alias `" <> a <> "` -> `" <> b <> "`") + +aliasAddHelp :: HelpPage +aliasAddHelp = + HelpPage + "add" + [] + "adds an alias" + [r|**Add Alias** +Adds an alias. + +*Usage:* `alias add ""`|] + [ HelpPage "private" [] "adds a private alias" "**Add Private Alias**\nAdds a private alias.\n\n*Usage:* `alias add private \"\"`" [] None, + HelpPage "public" [] "adds a public alias" "**Add Public Alias**\nAdds a public alias.\n\n*Usage:* `alias add public \"\"`" [] publicAliasPerms + ] + None + +aliasListCommand :: Command +aliasListCommand = + Command + "list" + (parseComm aliasListPrivateComm) + [ Command "private" (parseComm aliasListPrivateComm) [], + Command "public" (parseComm aliasListPublicComm) [] + ] + where + aliasListPrivateComm :: Message -> DatabaseDiscord () + aliasListPrivateComm m = aliasList (AliasPrivate (userId $ messageAuthor m)) m + aliasListPublicComm :: Message -> DatabaseDiscord () + aliasListPublicComm m = aliasList AliasPublic m + +aliasList :: AliasType -> Message -> DatabaseDiscord () +aliasList at m = do + aliases <- fmap Sql.entityVal <$> liftSql (Sql.selectList [AliasType Sql.==. at] []) + let msg = + aliasTypeToText at <> " aliases:\n" + <> T.unlines (map (\(Alias a b _) -> "\t`" <> a <> "` -> `" <> b <> "`") aliases) + sendMessage m msg + +aliasListHelp :: HelpPage +aliasListHelp = + HelpPage + "list" + [] + "lists aliases" + [r|**List Aliases** +Lists all aliases. +You can specify whether the aliases are public or private. + +*Usage:* `alias list`|] + [ HelpPage "private" [] "lists your private aliases" "**List Private Aliases**\nLists your private aliases.\n\n*Usage:* `alias list private`" [] None, + HelpPage "public" [] "lists the public aliases" "**List Public Aliases**\nLists the public aliases.\n\n*Usage:* `alias list public`" [] None + ] + None + +aliasDeleteCommand :: Command +aliasDeleteCommand = + Command + "delete" + (parseComm aliasDeletePrivateComm) + [ Command "private" (parseComm aliasDeletePrivateComm) [], + Command "public" (parseComm aliasDeletePublicComm) [] + ] + where + aliasDeletePrivateComm :: WithError "Need a single word" Text -> Message -> DatabaseDiscord () + aliasDeletePrivateComm (WErr t) m = aliasDelete t (AliasPrivate (userId $ messageAuthor m)) m + aliasDeletePublicComm :: WithError "Need a single word" Text -> Message -> DatabaseDiscord () + aliasDeletePublicComm (WErr t) m = requirePermission publicAliasPerms m $ aliasDelete t AliasPublic m + +aliasDelete :: Text -> AliasType -> Message -> DatabaseDiscord () +aliasDelete a at m = do + let toDelete = UniqueAlias a at + itemExists <- exists [AliasAlias Sql.==. a, AliasType Sql.==. at] + if itemExists + then deleteBy toDelete >> sendMessage m ("Deleted alias `" <> a <> "`") + else sendMessage m ("No such alias `" <> a <> "`") + +aliasDeleteHelp :: HelpPage +aliasDeleteHelp = + HelpPage + "delete" + ["remove"] + "deletes an alias" + [r|**Delete Alias** +Deletes a private alias. + +*Usage:* `alias delete `|] + [ HelpPage "private" [] "deletes a private alias" "**Delete Private Alias**\nDeletes a private alias.\n\n*Usage:* `alias delete private `" [] None, + HelpPage "public" [] "deletes a public alias" "**Delete Public Alias**\nDeletes a public alias.\n\n*Usage:* `alias delete public `" [] publicAliasPerms + ] + None diff --git a/src/Tablebot/Plugins/Basic.hs b/src/Tablebot/Plugins/Basic.hs index bcfba4b4..5d81945f 100644 --- a/src/Tablebot/Plugins/Basic.hs +++ b/src/Tablebot/Plugins/Basic.hs @@ -7,27 +7,16 @@ -- Portability : POSIX -- -- This is an example plugin which responds to certain calls with specific responses. -module Tablebot.Plugins.Basic (basicPlugin) where +module Tablebot.Plugins.Basic (basic) where import Data.Text as T (Text, toTitle) -import Discord.Internal.Rest (Message) +import Discord.Types (Message) +import Tablebot.Utility import Tablebot.Utility.Discord (sendMessage) import Tablebot.Utility.SmartParser (parseComm) -import Tablebot.Utility.Types - ( Command, - DatabaseDiscord, - EnvCommand (Command), - EnvInlineCommand (InlineCommand), - EnvPlugin (commands, inlineCommands), - HelpPage (HelpPage), - InlineCommand, - Plugin, - RequiredPermission (None), - helpPages, - plug, - ) import Text.Megaparsec (anySingle, skipManyTill) import Text.Megaparsec.Char (string') +import Text.RawString.QQ (r) -- * Some types to help clarify what's going on @@ -43,20 +32,12 @@ type BasicCommand = (Text, Text, MiniHelpPage) -- | The basic commands. basicCommands :: [BasicCommand] basicCommands = - [ ( "pr", - "You can make a pull request for that!", - Simple ("you know what to do", "You know what to do") - ), - ( "issue", - "You can submit an issue for that!", - Simple ("you know what you want someone else to do", "You know what you want someone else to do") - ), - ( "benji", + [ ( "benji", "<:benji_sit:920000993721196654>", Simple ("the almost mascot", "Though he may sit, when put to test, the gender cube proved it was best") ), ( "about", - "This bot was created by finnbar to replace a couple of other bots in Tabletop. It's written in Haskell, and you can find the github here: . There are setup guides and a contributor's guide to help you get started.", + aboutStr, Simple ("some information about the bot", "Some information about the bot, including how you can get involved") ), ( "inventory", @@ -64,6 +45,13 @@ basicCommands = Simple ("our board games inventory", "Our board games inventory, with a link to the actual inventory") ) ] + where + aboutStr = + [r|This bot was created by finnbar to replace a couple of other bots in Tabletop. +It's written in Haskell, and you can find the code here: . +If you would like to contribute, there are setup guides and a contributor's guide to help you get started! + +If you have found a bug, please report it on Github () or inform one of the maintainers.|] -- | @echo@ pulled out to help resolve parser overlapping instances errors. -- Sends the provided text, regardless of received message. @@ -100,3 +88,6 @@ basicPlugin = helpPages = map baseHelp basicCommands, inlineCommands = map baseInlineCommand basicInlineCommands } + +basic :: CompiledPlugin +basic = compilePlugin basicPlugin diff --git a/src/Tablebot/Plugins/Cats.hs b/src/Tablebot/Plugins/Cats.hs index 2f373c94..9d01f35a 100644 --- a/src/Tablebot/Plugins/Cats.hs +++ b/src/Tablebot/Plugins/Cats.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- This is an example plugin which just responds with a cat photo to a .cat call -module Tablebot.Plugins.Cats (catPlugin) where +module Tablebot.Plugins.Cats (cat) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson (FromJSON, Object, eitherDecode) @@ -18,18 +18,9 @@ import GHC.Generics (Generic) import Network.HTTP.Conduit (Response (responseBody), parseRequest) import Network.HTTP.Simple (addRequestHeader, httpLBS) import System.Environment (lookupEnv) +import Tablebot.Utility import Tablebot.Utility.Discord (Message, sendMessage) import Tablebot.Utility.SmartParser (parseComm) -import Tablebot.Utility.Types - ( Command, - DatabaseDiscord, - EnvCommand (Command), - EnvPlugin (..), - HelpPage (HelpPage), - Plugin, - RequiredPermission (None), - plug, - ) -- | @CatAPI@ is the basic data type for the JSON object that thecatapi returns data CatAPI = CatAPI @@ -43,10 +34,10 @@ data CatAPI = CatAPI instance FromJSON CatAPI --- | @cat@ is a command that takes no arguments (using 'noArguments') and +-- | @catCommand@ is a command that takes no arguments (using 'noArguments') and -- replies with an image of a cat. Uses https://docs.thecatapi.com/ for cats. -cat :: Command -cat = +catCommand :: Command +catCommand = Command "cat" (parseComm sendCat) @@ -87,4 +78,7 @@ catHelp = HelpPage "cat" [] "displays an image of a cat" "**Cat**\nGets a random -- | @catPlugin@ assembles these commands into a plugin containing cat catPlugin :: Plugin -catPlugin = (plug "cats") {commands = [cat], helpPages = [catHelp]} +catPlugin = (plug "cats") {commands = [catCommand], helpPages = [catHelp]} + +cat :: CompiledPlugin +cat = compilePlugin catPlugin diff --git a/src/Tablebot/Plugins/Dogs.hs b/src/Tablebot/Plugins/Dogs.hs index 177f4607..813d315a 100644 --- a/src/Tablebot/Plugins/Dogs.hs +++ b/src/Tablebot/Plugins/Dogs.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - -- | -- Module : Tablebot.Plugins.Dog -- Description : A very simple plugin that provides dog pictures. @@ -9,7 +7,7 @@ -- Portability : POSIX -- -- This is an example plugin which just responds with a dog photo to a .dog call -module Tablebot.Plugins.Dogs (dogPlugin) where +module Tablebot.Plugins.Dogs (dog) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Text (Text) @@ -17,23 +15,14 @@ import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Encoding (decodeUtf8) import Network.HTTP.Conduit (Response (responseBody), parseRequest) import Network.HTTP.Simple (httpLBS) +import Tablebot.Utility import Tablebot.Utility.Discord (Message, sendMessage) import Tablebot.Utility.SmartParser (parseComm) -import Tablebot.Utility.Types - ( Command, - DatabaseDiscord, - EnvCommand (Command), - EnvPlugin (..), - HelpPage (HelpPage), - Plugin, - RequiredPermission (None), - plug, - ) -- | @dog@ is a command that takes no arguments (using 'noArguments') and -- replies with an image of a dog. Uses https://randomdog.ca/ for dog images. -dog :: Command -dog = +dogCommand :: Command +dogCommand = Command "dog" (parseComm sendDog) @@ -58,4 +47,7 @@ dogHelp = HelpPage "dog" [] "displays an image of a dog" "**Dog**\nGets a random -- | @dogPlugin@ assembles these commands into a plugin containing dog dogPlugin :: Plugin -dogPlugin = (plug "dog") {commands = [dog], helpPages = [dogHelp]} +dogPlugin = (plug "dog") {commands = [dogCommand], helpPages = [dogHelp]} + +dog :: CompiledPlugin +dog = compilePlugin dogPlugin diff --git a/src/Tablebot/Plugins/Flip.hs b/src/Tablebot/Plugins/Flip.hs index 1b7274c6..66a2d0d3 100644 --- a/src/Tablebot/Plugins/Flip.hs +++ b/src/Tablebot/Plugins/Flip.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- A command that picks one random element from its given arguments. -module Tablebot.Plugins.Flip (flipPlugin) where +module Tablebot.Plugins.Flip (flips) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Text (pack) @@ -51,3 +51,6 @@ Randomly picks one element from its arguments or, if none are provided, picks fr -- | @flipPlugin@ assembles the command into a plugin. flipPlugin :: Plugin flipPlugin = (plug "flip") {commands = [flip], helpPages = [flipHelp]} + +flips :: CompiledPlugin +flips = compilePlugin flipPlugin diff --git a/src/Tablebot/Plugins/Fox.hs b/src/Tablebot/Plugins/Fox.hs index 454f4500..7610fb17 100644 --- a/src/Tablebot/Plugins/Fox.hs +++ b/src/Tablebot/Plugins/Fox.hs @@ -9,27 +9,18 @@ -- Portability : POSIX -- -- This is an example plugin which just responds with a fox photo to a .fox call -module Tablebot.Plugins.Fox (foxPlugin) where +module Tablebot.Plugins.Fox (fox) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson (FromJSON, eitherDecode) import Data.Functor ((<&>)) import Data.Text (Text, pack) -import GHC.Generics +import GHC.Generics (Generic) import Network.HTTP.Conduit (Response (responseBody), parseRequest) import Network.HTTP.Simple (httpLBS) +import Tablebot.Utility import Tablebot.Utility.Discord (Message, sendMessage) import Tablebot.Utility.SmartParser (parseComm) -import Tablebot.Utility.Types - ( Command, - DatabaseDiscord, - EnvCommand (Command), - EnvPlugin (..), - HelpPage (HelpPage), - Plugin, - RequiredPermission (None), - plug, - ) -- | @FoxAPI@ is the basic data type for the JSON object that the Fox API returns data FoxAPI = Fox @@ -42,8 +33,8 @@ instance FromJSON FoxAPI -- | @fox@ is a command that takes no arguments (using 'noArguments') and -- replies with an image of a fox. Uses https://randomfox.ca/ for fox images. -fox :: Command -fox = +foxCommand :: Command +foxCommand = Command "fox" (parseComm sendFox) @@ -75,4 +66,7 @@ foxHelp = HelpPage "fox" [] "displays an image of a fox" "**Fox**\nGets a random -- | @foxPlugin@ assembles these commands into a plugin containing fox foxPlugin :: Plugin -foxPlugin = (plug "fox") {commands = [fox], helpPages = [foxHelp]} +foxPlugin = (plug "fox") {commands = [foxCommand], helpPages = [foxHelp]} + +fox :: CompiledPlugin +fox = compilePlugin foxPlugin diff --git a/src/Tablebot/Plugins/Netrunner.hs b/src/Tablebot/Plugins/Netrunner.hs index ca79bbc0..ccf9a999 100644 --- a/src/Tablebot/Plugins/Netrunner.hs +++ b/src/Tablebot/Plugins/Netrunner.hs @@ -7,6 +7,10 @@ -- Portability : POSIX -- -- Commands for interfacing with NetrunnerDB. -module Tablebot.Plugins.Netrunner (netrunnerPlugin) where +module Tablebot.Plugins.Netrunner (netrunner) where import Tablebot.Plugins.Netrunner.Plugin (netrunnerPlugin) +import Tablebot.Utility (CompiledPlugin, compilePlugin) + +netrunner :: CompiledPlugin +netrunner = compilePlugin netrunnerPlugin diff --git a/src/Tablebot/Plugins/Netrunner/Plugin.hs b/src/Tablebot/Plugins/Netrunner/Plugin.hs index b8d071e9..cf18c490 100644 --- a/src/Tablebot/Plugins/Netrunner/Plugin.hs +++ b/src/Tablebot/Plugins/Netrunner/Plugin.hs @@ -192,8 +192,8 @@ nrRules = Command "rules" (parseComm rulesComm) [] rulesComm :: RestOfInput Text -> Message -> EnvDatabaseDiscord NrApi () rulesComm (ROI q) m = do let (rTitle, rBody, colour) = case getRuling q of - Left (Ruling t b) -> (t, b, Red) - Right (Ruling t b) -> (t, b, Blue) + Left (Ruling t b) -> (t, b, DiscordColorRed) + Right (Ruling t b) -> (t, b, DiscordColorBlue) sendEmbedMessage m "" $ addColour colour $ embedText rTitle rBody -- | @embedCard@ takes a card and embeds it in a message. @@ -234,9 +234,9 @@ embedBanHistory card m = do api <- ask embed <- cardToEmbedWithText api card $ listBanHistory api card let colour = case toMwlStatus api (activeBanList api) card of - Banned -> Red - Legal -> Green - _ -> Yellow + Banned -> DiscordColorRed + Legal -> DiscordColorGreen + _ -> DiscordColorYellow sendEmbedMessage m "" $ addColour colour embed -- | @embedBanLists@ embeds all banlists in Netrunner history. @@ -244,7 +244,7 @@ embedBanLists :: Message -> EnvDatabaseDiscord NrApi () embedBanLists m = do api <- ask let embed = embedTextWithUrl "Standard Banlists" "https://netrunnerdb.com/en/banlists" $ listBanLists api - colour = if latestBanListActive api then Red else Yellow + colour = if latestBanListActive api then DiscordColorRed else DiscordColorYellow sendEmbedMessage m "" $ addColour colour embed -- | @embedBanList@ embeds the list of cards affected by a given banlist. @@ -253,7 +253,7 @@ embedBanList banList m = do api <- ask let (pre, cCards, rCards) = listAffectedCards api banList header = BanList.name banList <> if active banList then " (active)" else "" - colour = if active banList then Red else Yellow + colour = if active banList then DiscordColorRed else DiscordColorYellow sendEmbedMessage m "" $ addColour colour $ embedColumns header pre [("Corp Cards", cCards), ("Runner Cards", rCards)] beginnerText :: EnvDatabaseDiscord NrApi Text diff --git a/src/Tablebot/Plugins/Netrunner/Utility/Card.hs b/src/Tablebot/Plugins/Netrunner/Utility/Card.hs index f7c9523b..9d19ac4c 100644 --- a/src/Tablebot/Plugins/Netrunner/Utility/Card.hs +++ b/src/Tablebot/Plugins/Netrunner/Utility/Card.hs @@ -38,7 +38,6 @@ import Tablebot.Plugins.Netrunner.Utility.BanList (activeBanList, isBanned, isRe import Tablebot.Plugins.Netrunner.Utility.Misc (formatNr) import Tablebot.Utility import Tablebot.Utility.Types () -import Tablebot.Utility.Utils (intToText, maybeEmptyPrepend) -- | @toLink@ takes a card and generates a link to its NetrunnerDB page. toLink :: Card -> Text @@ -174,8 +173,8 @@ toReleaseData api card = fromMaybe "" helper return $ faction <> " • " <> expansion <> pos -- | @toColour@ gets the factional colour of a card to use in its embed. -toColour :: NrApi -> Card -> DiscordColour -toColour api card = maybe Default (hexToDiscordColour . unpack . Faction.colour) (toFaction api card) +toColour :: NrApi -> Card -> DiscordColor +toColour api card = maybe DiscordColorDefault (hexToDiscordColor . unpack . Faction.colour) (toFaction api card) -- | @toFlavour@ gets a cards flavour text (and makes it italic). toFlavour :: Card -> EnvDatabaseDiscord NrApi (Maybe Text) diff --git a/src/Tablebot/Plugins/Netrunner/Utility/Embed.hs b/src/Tablebot/Plugins/Netrunner/Utility/Embed.hs index 45b6a22f..4dc7b4fb 100644 --- a/src/Tablebot/Plugins/Netrunner/Utility/Embed.hs +++ b/src/Tablebot/Plugins/Netrunner/Utility/Embed.hs @@ -37,7 +37,7 @@ import Tablebot.Utility.Types () import Prelude hiding (unwords) -- | @cardToEmbed@ takes a card and generates an embed message representing it. -cardToEmbed :: NrApi -> Card -> EnvDatabaseDiscord NrApi Embed +cardToEmbed :: NrApi -> Card -> EnvDatabaseDiscord NrApi CreateEmbed cardToEmbed api card = do let eTitle = toTitle card eURL = toLink card @@ -45,25 +45,25 @@ cardToEmbed api card = do eImg = toImage api card eColour = toColour api card eText <- toText card - return $ addColour eColour $ createEmbed $ CreateEmbed "" "" Nothing eTitle eURL eImg eText [] Nothing eFoot Nothing Nothing + return $ addColour eColour $ CreateEmbed "" "" Nothing eTitle eURL eImg eText [] Nothing eFoot Nothing Nothing Nothing -- | @cardToEmbedWithText@ embeds some text and decorates it with a given card. -cardToEmbedWithText :: NrApi -> Card -> Text -> EnvDatabaseDiscord NrApi Embed +cardToEmbedWithText :: NrApi -> Card -> Text -> EnvDatabaseDiscord NrApi CreateEmbed cardToEmbedWithText api card text = do let eTitle = toTitle card eURL = toLink card eColour = toColour api card eImg = toImage api card - return $ addColour eColour $ createEmbed $ CreateEmbed "" "" Nothing eTitle eURL eImg text [] Nothing "" Nothing Nothing + return $ addColour eColour $ CreateEmbed "" "" Nothing eTitle eURL eImg text [] Nothing "" Nothing Nothing Nothing -- | @cardsToEmbed@ takes a list of cards and embeds their names with links. -cardsToEmbed :: NrApi -> Text -> [Card] -> Text -> EnvDatabaseDiscord NrApi Embed +cardsToEmbed :: NrApi -> Text -> [Card] -> Text -> EnvDatabaseDiscord NrApi CreateEmbed cardsToEmbed api pre cards err = do formatted <- mapM formatCard $ take 10 cards let cards' = "**" <> intercalate "\n" formatted <> "**" eTitle = "**" <> pack (show $ length cards) <> " results**" eText = pre <> "\n" <> cards' <> if length cards > 10 then "\n" <> err else "" - return $ createEmbed $ CreateEmbed "" "" Nothing eTitle "" Nothing eText [] Nothing "" Nothing Nothing + return $ CreateEmbed "" "" Nothing eTitle "" Nothing eText [] Nothing "" Nothing Nothing Nothing where formatCard :: Card -> EnvDatabaseDiscord NrApi Text formatCard card = do @@ -75,57 +75,57 @@ cardsToEmbed api pre cards err = do return $ icon <> " [" <> title' <> "](" <> link <> ")" -- | @cardToImgEmbed@ takes a card and attempts to embed a picture of it. -cardToImgEmbed :: NrApi -> Card -> Embed +cardToImgEmbed :: NrApi -> Card -> CreateEmbed cardToImgEmbed api card = let eTitle = toTitle card eURL = toLink card eColour = toColour api card in addColour eColour $ - createEmbed $ case toImage api card of - Nothing -> CreateEmbed "" "" Nothing eTitle eURL Nothing "`Could not find card art`" [] Nothing "" Nothing Nothing - eImg -> CreateEmbed "" "" Nothing eTitle eURL Nothing "" [] eImg "" Nothing Nothing + case toImage api card of + Nothing -> CreateEmbed "" "" Nothing eTitle eURL Nothing "`Could not find card art`" [] Nothing "" Nothing Nothing Nothing + eImg -> CreateEmbed "" "" Nothing eTitle eURL Nothing "" [] eImg "" Nothing Nothing Nothing -- | @cardToFlavourEmbed@ takes a card and attempts to embed its flavour text. -cardToFlavourEmbed :: NrApi -> Card -> EnvDatabaseDiscord NrApi Embed +cardToFlavourEmbed :: NrApi -> Card -> EnvDatabaseDiscord NrApi CreateEmbed cardToFlavourEmbed api card = do let eTitle = toTitle card eURL = toLink card eColour = toColour api card eImg = toImage api card - fallback = CreateEmbed "" "" Nothing eTitle eURL eImg "`Card has no flavour text`" [] Nothing "" Nothing Nothing + fallback = CreateEmbed "" "" Nothing eTitle eURL eImg "`Card has no flavour text`" [] Nothing "" Nothing Nothing Nothing flavor <- toFlavour card return $ addColour eColour $ - createEmbed $ case flavor of + case flavor of Nothing -> fallback Just "" -> fallback - Just eFlavour -> CreateEmbed "" "" Nothing eTitle eURL eImg eFlavour [] Nothing "" Nothing Nothing + Just eFlavour -> CreateEmbed "" "" Nothing eTitle eURL eImg eFlavour [] Nothing "" Nothing Nothing Nothing -- | @embedText@ just embeds the given text. -embedText :: Text -> Text -> Embed -embedText title text = createEmbed $ CreateEmbed "" "" Nothing title "" Nothing text [] Nothing "" Nothing Nothing +embedText :: Text -> Text -> CreateEmbed +embedText title text = CreateEmbed "" "" Nothing title "" Nothing text [] Nothing "" Nothing Nothing Nothing -- | @embedTextWithUrl@ is @embedText@ but you can set the title URL. -embedTextWithUrl :: Text -> Text -> Text -> Embed -embedTextWithUrl title url text = createEmbed $ CreateEmbed "" "" Nothing title url Nothing text [] Nothing "" Nothing Nothing +embedTextWithUrl :: Text -> Text -> Text -> CreateEmbed +embedTextWithUrl title url text = CreateEmbed "" "" Nothing title url Nothing text [] Nothing "" Nothing Nothing Nothing -- | @embedColumns@ embeds Text into columns. -embedColumns :: Text -> Text -> [(Text, [Text])] -> Embed +embedColumns :: Text -> Text -> [(Text, [Text])] -> CreateEmbed embedColumns title pre cols = let fields = map (\x -> EmbedField (fst x) (intercalate "\n" $ snd x) $ Just True) cols - in createEmbed $ CreateEmbed "" "" Nothing title "" Nothing pre fields Nothing "" Nothing Nothing + in CreateEmbed "" "" Nothing title "" Nothing pre fields Nothing "" Nothing Nothing Nothing -- | @embedLines@ embeds a list of lines, splitting them into columns as needed. -- NOTE: does not preserve order -embedLines :: Text -> Text -> [Text] -> Embed +embedLines :: Text -> Text -> [Text] -> CreateEmbed embedLines title pre xs = let cumLength = scanl (\l x -> 1 + T.length x + l) (T.length title + 2) xs -- +1 for each newline title characters safeIndex = length $ takeWhile (< 1900) cumLength -- 1900 instead of 2000 because I gave up trying to be exact xs' = take safeIndex xs - c = if length xs' < 12 then 1 else 2 --if length xs' < 27 then 2 else 3 + c = if length xs' < 12 then 1 else 2 d = length xs' `div` c m = length xs' `mod` c heights = replicate m (d + 1) ++ replicate (c - m) d cols = splitPlaces heights xs' fields = map (\x -> EmbedField "⠀" (intercalate "\n" x) $ Just True) cols - in createEmbed $ CreateEmbed "" "" Nothing title "" Nothing pre fields Nothing "" Nothing Nothing + in CreateEmbed "" "" Nothing title "" Nothing pre fields Nothing "" Nothing Nothing Nothing diff --git a/src/Tablebot/Plugins/Ping.hs b/src/Tablebot/Plugins/Ping.hs index d42e46c6..247ff4a3 100644 --- a/src/Tablebot/Plugins/Ping.hs +++ b/src/Tablebot/Plugins/Ping.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- This is an example plugin which just responds "ping" to "!pong" and vice-versa. -module Tablebot.Plugins.Ping (pingPlugin) where +module Tablebot.Plugins.Ping (pingpong) where import Data.Text (Text) import Tablebot.Utility @@ -29,23 +29,13 @@ ping = ) [] --- | @pong@ is a command that takes no arguments (using 'noArguments') and --- replies with "ping". It is the younger sibling of @ping@. -pong :: Command -pong = - Command - "pong" - ( parseComm $ echo "ping" - ) - [] - pingHelp :: HelpPage pingHelp = HelpPage "ping" [] "show a debug message" "**Ping**\nShows a debug message\n\n*Usage:* `ping`" [] None -pongHelp :: HelpPage -pongHelp = HelpPage "pong" [] "show a more different debug message" "**Pong**\nShows a different debug message\n\n*Usage:* `pong`" [] None - -- | @pingPlugin@ assembles these commands into a plugin containing both ping -- and pong. pingPlugin :: Plugin -pingPlugin = (plug "ping") {commands = [ping, pong], helpPages = [pingHelp, pongHelp]} +pingPlugin = (plug "ping") {commands = [ping], helpPages = [pingHelp]} + +pingpong :: CompiledPlugin +pingpong = compilePlugin pingPlugin diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index cc2e4cd0..01a4f2cb 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | @@ -10,15 +11,20 @@ -- -- This is an example plugin which allows user to @!quote add@ their favourite -- quotes and then @!quote show n@ a particular quote. -module Tablebot.Plugins.Quote (quotePlugin) where +module Tablebot.Plugins.Quote (quotes) where -import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import Data.Aeson +import Data.Default (Default (def)) +import Data.Functor ((<&>)) +import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text, append, pack, unpack) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, systemToUTCTime) -import Database.Persist.Sqlite (Filter, SelectOpt (LimitTo, OffsetBy), entityVal, (==.)) +import Database.Persist.Sqlite (Entity (entityKey), Filter, SelectOpt (LimitTo, OffsetBy), entityVal, (==.)) import Database.Persist.TH +import Discord (restCall) +import Discord.Interactions +import qualified Discord.Internal.Rest.Interactions as R import Discord.Types import GHC.Generics (Generic) import GHC.Int (Int64) @@ -26,19 +32,21 @@ import System.Random (randomRIO) import Tablebot.Utility import Tablebot.Utility.Database import Tablebot.Utility.Discord - ( findGuild, - getMessage, + ( getMessage, getMessageLink, getPrecedingMessage, getReplyMessage, - sendEmbedMessage, + interactionResponseAutocomplete, + interactionResponseCustomMessage, + sendCustomMessage, sendMessage, toMention, toMention', ) import Tablebot.Utility.Embed -import Tablebot.Utility.Exception (BotException (GenericException), catchBot, throwBot) +import Tablebot.Utility.Exception (BotException (GenericException, InteractionException), catchBot, throwBot) import Tablebot.Utility.Permission (requirePermission) +import Tablebot.Utility.Search import Tablebot.Utility.SmartParser import Text.RawString.QQ (r) @@ -67,12 +75,12 @@ quoteReactionAdd = ReactionAdd quoteReaction m <- getMessage (reactionChannelId ri) (reactionMessageId ri) case m of Left _ -> pure () - Right mes -> addMessageQuote (reactionUserId ri) mes mes + Right mes -> addMessageQuote (reactionUserId ri) mes mes >>= sendCustomMessage mes | otherwise = return () -- | Our quote command, which combines various functions to create, display and update quotes. -quote :: Command -quote = +quoteCommand :: Command +quoteCommand = Command "quote" (parseComm quoteComm) @@ -84,9 +92,9 @@ quote = (Either () (Either Int64 (RestOfInput Text))) -> Message -> DatabaseDiscord () - quoteComm (WErr (Left ())) = randomQ - quoteComm (WErr (Right (Left t))) = showQ t - quoteComm (WErr (Right (Right (ROI t)))) = authorQ t + quoteComm (WErr (Left ())) m = randomQ m >>= sendCustomMessage m + quoteComm (WErr (Right (Left t))) m = showQ t m >>= sendCustomMessage m + quoteComm (WErr (Right (Right (ROI t)))) m = authorQ t m >>= sendCustomMessage m addQuote :: Command addQuote = Command "add" (parseComm addComm) [] @@ -95,7 +103,7 @@ addQuote = Command "add" (parseComm addComm) [] WithError "Quote format incorrect!\nFormat is: .quote \"quote\" - author" (Quoted Text, Exactly "-", RestOfInput Text) -> Message -> DatabaseDiscord () - addComm (WErr (Qu qu, _, ROI author)) = addQ qu author + addComm (WErr (Qu qu, _, ROI author)) m = addQ qu author m >>= sendCustomMessage m editQuote :: Command editQuote = Command "edit" (parseComm editComm) [] @@ -114,6 +122,21 @@ thisQuote = Command "this" (parseComm thisComm) [] thisComm :: Message -> DatabaseDiscord () thisComm = thisQ +quoteMessageAppComm :: Maybe ApplicationCommandRecv +quoteMessageAppComm = appcomm <&> (`ApplicationCommandRecv` recv) + where + appcomm = createMessage "quote" + recv i@InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataMessage {..}, ..} = do + let mid = applicationCommandDataTargetMessageId + case interactionChannelId of + Nothing -> throwBot $ InteractionException "no channel id in quote interaction" + Just cid -> do + m <- getMessage cid mid + case m of + Left _ -> throwBot $ InteractionException "could not get message to quote" + Right msg -> interactionResponseCustomMessage i =<< addMessageQuote (contextUserId i) msg i + recv _ = return def + authorQuote :: Command authorQuote = Command "author" (parseComm authorComm) [] where @@ -121,7 +144,7 @@ authorQuote = Command "author" (parseComm authorComm) [] WithError "Quote format incorrect!\nExpected author name to find quotes for after .quote author" (RestOfInput Text) -> Message -> DatabaseDiscord () - authorComm (WErr (ROI author)) = authorQ author + authorComm (WErr (ROI author)) m = authorQ author m >>= sendCustomMessage m showQuote :: Command showQuote = Command "show" (parseComm showComm) [] @@ -130,7 +153,7 @@ showQuote = Command "show" (parseComm showComm) [] WithError "Quote format incorrect!\nExpected quote number to show, e.g. .quote show 420" Int64 -> Message -> DatabaseDiscord () - showComm (WErr qId) = showQ qId + showComm (WErr qId) m = showQ qId m >>= sendCustomMessage m deleteQuote :: Command deleteQuote = Command "delete" (parseComm deleteComm) [] @@ -145,62 +168,75 @@ randomQuote :: Command randomQuote = Command "random" (parseComm randomComm) [] where randomComm :: Message -> DatabaseDiscord () - randomComm = randomQ + randomComm m = randomQ m >>= sendCustomMessage m -- | @showQuote@, which looks for a message of the form @!quote show n@, looks -- that quote up in the database and responds with that quote. -showQ :: Int64 -> Message -> DatabaseDiscord () +showQ :: Context m => Int64 -> m -> DatabaseDiscord MessageDetails showQ qId m = do qu <- get $ toSqlKey qId case qu of - Just q -> renderQuoteMessage q qId m - Nothing -> sendMessage m "Couldn't get that quote!" + Just q -> renderQuoteMessage q qId Nothing m + Nothing -> return $ messageDetailsBasic "Couldn't get that quote!" -- | @randomQuote@, which looks for a message of the form @!quote random@, -- selects a random quote from the database and responds with that quote. -randomQ :: Message -> DatabaseDiscord () -randomQ = filteredRandomQuote [] "Couldn't find any quotes!" +randomQ :: Context m => m -> DatabaseDiscord MessageDetails +randomQ = filteredRandomQuote [] "Couldn't find any quotes!" (Just randomButton) + where + randomButton = mkButton "Random quote" "quote random" + +randomQuoteComponentRecv :: ComponentRecv +randomQuoteComponentRecv = ComponentRecv "random" (processComponentInteraction (randomQ @Interaction) True) -- | @authorQuote@, which looks for a message of the form @!quote author u@, -- selects a random quote from the database attributed to u and responds with that quote. -authorQ :: Text -> Message -> DatabaseDiscord () -authorQ t = filteredRandomQuote [QuoteAuthor ==. t] "Couldn't find any quotes with that author!" +authorQ :: Context m => Text -> m -> DatabaseDiscord MessageDetails +authorQ t = filteredRandomQuote [QuoteAuthor ==. t] "Couldn't find any quotes with that author!" (Just authorButton) + where + authorButton = mkButton "Random author quote" ("quote author " <> t) + +authorQuoteComponentRecv :: ComponentRecv +authorQuoteComponentRecv = ComponentRecv "author" (processComponentInteraction (\(ROI t) -> authorQ @Interaction t) True) -- | @filteredRandomQuote@ selects a random quote that meets a -- given criteria, and returns that as the response, sending the user a message if the -- quote cannot be found. -filteredRandomQuote :: [Filter Quote] -> Text -> Message -> DatabaseDiscord () -filteredRandomQuote quoteFilter errorMessage m = catchBot (filteredRandomQuote' quoteFilter errorMessage m) catchBot' +filteredRandomQuote :: Context m => [Filter Quote] -> Text -> Maybe Button -> m -> DatabaseDiscord MessageDetails +filteredRandomQuote quoteFilter errorMessage mb m = catchBot (filteredRandomQuote' quoteFilter errorMessage mb m) catchBot' where - catchBot' (GenericException "quote exception" _) = sendMessage m errorMessage + catchBot' (GenericException "quote exception" _) = return $ (messageDetailsBasic errorMessage) {messageDetailsEmbeds = Just [], messageDetailsComponents = Just []} catchBot' e = throwBot e -- | @filteredRandomQuote'@ selects a random quote that meets a -- given criteria, and returns that as the response, throwing an exception if something -- goes wrong. -filteredRandomQuote' :: [Filter Quote] -> Text -> Message -> DatabaseDiscord () -filteredRandomQuote' quoteFilter errorMessage m = do +filteredRandomQuote' :: Context m => [Filter Quote] -> Text -> Maybe Button -> m -> DatabaseDiscord MessageDetails +filteredRandomQuote' quoteFilter errorMessage mb m = do num <- count quoteFilter - if num == 0 + if num == 0 -- we can't find any quotes meeting the filter then throwBot (GenericException "quote exception" (unpack errorMessage)) else do rindex <- liftIO $ randomRIO (0, num - 1) key <- selectKeysList quoteFilter [OffsetBy rindex, LimitTo 1] qu <- get $ head key case qu of - Just q -> renderQuoteMessage q (fromSqlKey $ head key) m + Just q -> renderQuoteMessage q (fromSqlKey $ head key) mb m Nothing -> throwBot (GenericException "quote exception" (unpack errorMessage)) -- | @addQuote@, which looks for a message of the form -- @!quote add "quoted text" - author@, and then stores said quote in the -- database, returning the ID used. -addQ :: Text -> Text -> Message -> DatabaseDiscord () -addQ qu author m = do +addQ :: Text -> Text -> Message -> DatabaseDiscord MessageDetails +addQ qu author m = fst <$> addQ' qu author (toMention $ messageAuthor m) (messageId m) (messageChannelId m) m + +addQ' :: Context m => Text -> Text -> Text -> MessageId -> ChannelId -> m -> DatabaseDiscord (MessageDetails, Int64) +addQ' qu author requestor sourceMsg sourceChannel m = do now <- liftIO $ systemToUTCTime <$> getSystemTime - let new = Quote qu author (toMention $ messageAuthor m) (fromIntegral $ messageId m) (fromIntegral $ messageChannel m) now + let new = Quote qu author requestor (fromIntegral sourceMsg) (fromIntegral sourceChannel) now added <- insert new let res = pack $ show $ fromSqlKey added - renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) m + renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) Nothing m <&> (,fromSqlKey added) -- | @thisQuote@, which takes the replied message or the -- previous message and stores said message as a quote in the database, @@ -209,15 +245,15 @@ thisQ :: Message -> DatabaseDiscord () thisQ m = do q <- getReplyMessage m case q of - (Just q') -> addMessageQuote (userId $ messageAuthor m) q' m + (Just q') -> addMessageQuote (userId $ messageAuthor m) q' m >>= sendCustomMessage m Nothing -> do q2 <- getPrecedingMessage m case q2 of - (Just q') -> addMessageQuote (userId $ messageAuthor m) q' m + (Just q') -> addMessageQuote (userId $ messageAuthor m) q' m >>= sendCustomMessage m Nothing -> sendMessage m "Unable to add quote" -- | @addMessageQuote@, adds a message as a quote to the database, checking that it passes the relevant tests -addMessageQuote :: UserId -> Message -> Message -> DatabaseDiscord () +addMessageQuote :: Context m => UserId -> Message -> m -> DatabaseDiscord MessageDetails addMessageQuote submitter q' m = do num <- count [QuoteMsgId ==. fromIntegral (messageId q')] if num == 0 @@ -227,34 +263,37 @@ addMessageQuote submitter q' m = do now <- liftIO $ systemToUTCTime <$> getSystemTime let new = Quote - (messageText q') + (messageContent q') (toMention $ messageAuthor q') (toMention' submitter) (fromIntegral $ messageId q') - (fromIntegral $ messageChannel q') + (fromIntegral $ messageChannelId q') now added <- insert new let res = pack $ show $ fromSqlKey added - renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) m - else sendMessage m "Can't quote a bot" - else sendMessage m "Message already quoted" + renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) Nothing m + else return $ makeEphermeral (messageDetailsBasic "Can't quote a bot") + else return $ makeEphermeral (messageDetailsBasic "Message already quoted") -- | @editQuote@, which looks for a message of the form -- @!quote edit n "quoted text" - author@, and then updates quote with id n in the -- database, to match the provided quote. editQ :: Int64 -> Text -> Text -> Message -> DatabaseDiscord () -editQ qId qu author m = +editQ qId qu author m = editQ' qId (Just qu) (Just author) (toMention $ messageAuthor m) (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) m >>= sendCustomMessage m + +editQ' :: Context m => Int64 -> Maybe Text -> Maybe Text -> Text -> MessageId -> ChannelId -> m -> DatabaseDiscord MessageDetails +editQ' qId qu author requestor mid cid m = requirePermission Any m $ let k = toSqlKey qId in do - oQu <- get k + (oQu :: Maybe Quote) <- get k case oQu of - Just Quote {} -> do + Just (Quote qu' author' _ _ _ _) -> do now <- liftIO $ systemToUTCTime <$> getSystemTime - let new = Quote qu author (toMention $ messageAuthor m) (fromIntegral $ messageId m) (fromIntegral $ messageChannel m) now + let new = Quote (fromMaybe qu' qu) (fromMaybe author' author) requestor (fromIntegral mid) (fromIntegral cid) now replace k new - renderCustomQuoteMessage "Quote updated" new qId m - Nothing -> sendMessage m "Couldn't update that quote!" + renderCustomQuoteMessage "Quote updated" new qId Nothing m + Nothing -> return $ messageDetailsBasic "Couldn't update that quote!" -- | @deleteQuote@, which looks for a message of the form @!quote delete n@, -- and removes it from the database. @@ -270,22 +309,25 @@ deleteQ qId m = sendMessage m "Quote deleted" Nothing -> sendMessage m "Couldn't delete that quote!" -renderQuoteMessage :: Quote -> Int64 -> Message -> DatabaseDiscord () +renderQuoteMessage :: Context m => Quote -> Int64 -> Maybe Button -> m -> DatabaseDiscord MessageDetails renderQuoteMessage = renderCustomQuoteMessage "" -renderCustomQuoteMessage :: Text -> Quote -> Int64 -> Message -> DatabaseDiscord () -renderCustomQuoteMessage t (Quote txt author submitter msgId cnlId dtm) qId m = do - guild <- findGuild m +renderCustomQuoteMessage :: Context m => Text -> Quote -> Int64 -> Maybe Button -> m -> DatabaseDiscord MessageDetails +renderCustomQuoteMessage t (Quote txt author submitter msgId cnlId dtm) qId mb m = do + guild <- contextGuildId m let link = getLink guild - void $ - sendEmbedMessage - m - t - ( addColour Blue $ - addTimestamp dtm $ - addFooter (pack $ "Quote #" ++ show qId) $ - simpleEmbed (txt <> "\n - " <> author <> maybeAddFooter link) - ) + return + ( (messageDetailsBasic t) + { messageDetailsEmbeds = + Just + [ addColour DiscordColorBlue $ + addTimestamp dtm $ + addFooter (pack $ "Quote #" ++ show qId) $ + simpleEmbed (txt <> "\n - " <> author <> maybeAddFooter link) + ], + messageDetailsComponents = mb >>= \b -> Just [ActionRowButtons [b]] + } + ) where getLink :: Maybe GuildId -> Maybe Text getLink = fmap (\x -> getMessageLink x (fromIntegral cnlId) (fromIntegral msgId)) @@ -293,6 +335,155 @@ renderCustomQuoteMessage t (Quote txt author submitter msgId cnlId dtm) qId m = maybeAddFooter (Just l) = "\n[source](" <> l <> ") - added by " <> submitter maybeAddFooter Nothing = "" +quoteApplicationCommand :: CreateApplicationCommand +quoteApplicationCommand = CreateApplicationCommandChatInput "quote" "store and retrieve quotes" (Just opts) Nothing True + where + opts = + OptionsSubcommands $ + OptionSubcommandOrGroupSubcommand + <$> [ addQuoteAppComm, + showQuoteAppComm, + randomQuoteAppComm, + authorQuoteAppComm, + editQuoteAppComm + ] + addQuoteAppComm = + OptionSubcommand + "add" + "add a new quote" + [ OptionValueString "quote" "what the actual quote is" True (Left False), + OptionValueString "author" "who authored this quote" True (Left False) + ] + showQuoteAppComm = + OptionSubcommand + "show" + "show a quote by number" + [ OptionValueInteger "id" "the quote's number" True (Left True) (Just 1) Nothing + ] + randomQuoteAppComm = + OptionSubcommand + "random" + "show a random quote" + [] + authorQuoteAppComm = + OptionSubcommand + "author" + "show a random quote by an author" + [OptionValueString "author" "whose quotes do you want to see" True (Left False)] + editQuoteAppComm = + OptionSubcommand + "edit" + "edit a quote" + [ OptionValueInteger "quoteid" "the id of the quote to edit" True (Left False) Nothing Nothing, + OptionValueString "quote" "what the actual quote is" False (Left False), + OptionValueString "author" "who authored this quote" False (Left False) + ] + +quoteApplicationCommandRecv :: Interaction -> DatabaseDiscord () +quoteApplicationCommandRecv + i@InteractionApplicationCommand + { applicationCommandData = + ApplicationCommandDataChatInput + { optionsData = + Just + ( OptionsDataSubcommands + [OptionDataSubcommandOrGroupSubcommand subc] + ) + } + } = + case subcname of + "random" -> randomQ i >>= interactionResponseCustomMessage i + "author" -> + handleNothing + (getValue "author" vals >>= stringFromOptionValue) + ( \author -> authorQ author i >>= interactionResponseCustomMessage i + ) + "show" -> + handleNothing + (getValue "id" vals >>= integerFromOptionValue) + ( \showid -> showQ (fromIntegral showid) i >>= interactionResponseCustomMessage i + ) + "add" -> + handleNothing + ((getValue "quote" vals >>= stringFromOptionValue) >>= \q -> (getValue "author" vals >>= stringFromOptionValue) <&> (q,)) + ( \(qt, author) -> do + let requestor = toMention' $ contextUserId i + (msg, qid) <- addQ' qt author requestor 0 0 i + interactionResponseCustomMessage i msg + -- to get the message to display as wanted, we have to do some trickery + -- we have already sent off the message above with the broken message id + -- and channel id, but now we have sent off this message we can refer + -- to it! We just have to get that message, overwrite the quote, and + -- hope no one cares about the edit message + v <- liftDiscord $ restCall $ R.GetOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) + case v of + Left _ -> return () + Right m -> do + now <- liftIO $ systemToUTCTime <$> getSystemTime + let new = Quote qt author requestor (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) now + replace (toSqlKey qid) new + newMsg <- renderCustomQuoteMessage (messageContent m) new qid Nothing i + _ <- liftDiscord $ restCall $ R.EditOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) (convertMessageFormatInteraction newMsg) + return () + ) + "edit" -> + handleNothing + (getValue "quoteid" vals >>= integerFromOptionValue) + ( \qid' -> do + let qid = fromIntegral qid' + qt = getValue "quote" vals >>= stringFromOptionValue + author = getValue "author" vals >>= stringFromOptionValue + case (qt, author) of + (Nothing, Nothing) -> interactionResponseCustomMessage i (makeEphermeral (messageDetailsBasic "No edits made to quote.")) + _ -> do + msg <- editQ' qid qt author (toMention' $ contextUserId i) 0 0 i + interactionResponseCustomMessage i msg + v <- liftDiscord $ restCall $ R.GetOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) + case v of + Left _ -> return () + Right m -> do + msg' <- editQ' qid qt author (toMention' $ contextUserId i) (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) i + _ <- liftDiscord $ restCall $ R.EditOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) (convertMessageFormatInteraction msg') + return () + ) + _ -> throwBot $ InteractionException "unexpected quote interaction" + where + subcname = optionDataSubcommandName subc + vals = optionDataSubcommandOptions subc + handleNothing Nothing _ = return () + handleNothing (Just a) f = f a +quoteApplicationCommandRecv + i@InteractionApplicationCommandAutocomplete + { applicationCommandData = + ApplicationCommandDataChatInput + { optionsData = + Just + ( OptionsDataSubcommands + [OptionDataSubcommandOrGroupSubcommand subc] + ) + } + } = + case subcname of + "show" -> + handleNothing + (getValue "id" vals) + ( \case + OptionDataValueInteger _ (Right showid') -> interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger [Choice (pack $ show showid') showid'] + OptionDataValueInteger _ (Left showid') -> do + allQ <- allQuotes () + let allQ' = (\qe -> (show (fromSqlKey $ entityKey qe), (fromSqlKey $ entityKey qe, (\(Quote q _ _ _ _ _) -> q) (entityVal qe)))) <$> allQ + options = take 25 $ closestPairsWithCosts (def {deletion = 100, substitution = 100, transposition = 5}) allQ' (unpack showid') + interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger ((\(qids, (qid, _)) -> Choice (pack qids) (toInteger qid)) <$> options) + _ -> return () + ) + _ -> return () + where + subcname = optionDataSubcommandName subc + vals = optionDataSubcommandOptions subc + handleNothing Nothing _ = return () + handleNothing (Just a) f = f a +quoteApplicationCommandRecv _ = return () + showQuoteHelp :: HelpPage showQuoteHelp = HelpPage @@ -316,10 +507,10 @@ randomQuoteHelp = authorQuoteHelp :: HelpPage authorQuoteHelp = HelpPage - "user" + "author" [] - "show a random quote by a user" - "**Random User Quote**\nDisplays a random quote attributed to a particular user\n\n*Usage:* `quote user `" + "show a random quote by a author" + "**Random User Quote**\nDisplays a random quote attributed to a particular author\n\n*Usage:* `quote author `" [] Superuser @@ -386,12 +577,17 @@ Calling without arguments returns a random quote. Calling with a number returns quotePlugin :: Plugin quotePlugin = (plug "quote") - { commands = [quote, commandAlias "q" quote], + { commands = [quoteCommand, commandAlias "q" quoteCommand], onReactionAdds = [quoteReactionAdd], migrations = [quoteMigration], - helpPages = [quoteHelp] + helpPages = [quoteHelp], + applicationCommands = [ApplicationCommandRecv quoteApplicationCommand quoteApplicationCommandRecv] ++ catMaybes [quoteMessageAppComm], + onComponentRecvs = [randomQuoteComponentRecv, authorQuoteComponentRecv] } +quotes :: CompiledPlugin +quotes = compilePlugin quotePlugin + deriving instance Generic Quote instance FromJSON Quote @@ -399,8 +595,8 @@ instance FromJSON Quote instance ToJSON Quote -- | Get all the quotes in the database. -allQuotes :: DatabaseDiscord [Quote] -allQuotes = fmap entityVal <$> selectList [] [] +allQuotes :: () -> DatabaseDiscord [Entity Quote] +allQuotes _ = selectList [] [] -- | Export all the quotes in the database to either a default quotes file or to a given -- file name that is quoted in the command. Superuser only. @@ -411,7 +607,7 @@ exportQ :: Maybe (Quoted FilePath) -> Message -> DatabaseDiscord () exportQ qfp m = requirePermission Superuser m $ do let defFileName = getSystemTime >>= \now -> return $ "quotes_" <> show (systemSeconds now) <> ".json" (Qu fp) <- liftIO $ maybe (Qu <$> defFileName) return qfp - aq <- allQuotes + aq <- fmap entityVal <$> allQuotes () _ <- liftIO $ encodeFile fp aq sendMessage m ("Succesfully exported all " <> (pack . show . length) aq <> " quotes to `" <> pack fp <> "`") diff --git a/src/Tablebot/Plugins/Reminder.hs b/src/Tablebot/Plugins/Reminder.hs index 7f34b93b..528b8dfa 100644 --- a/src/Tablebot/Plugins/Reminder.hs +++ b/src/Tablebot/Plugins/Reminder.hs @@ -10,10 +10,7 @@ -- -- This is an example plugin which allows user to ask the bot to remind them about -- something later in time. -module Tablebot.Plugins.Reminder - ( reminderPlugin, - ) -where +module Tablebot.Plugins.Reminder (reminder) where import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -93,9 +90,9 @@ reminderParser (WErr (Qu content, ROI rawString)) m = do -- currently ignores the user's timezone... (TODO fix) addReminder :: UTCTime -> String -> Message -> DatabaseDiscord () addReminder time content m = do - let (Snowflake cid) = messageChannel m - (Snowflake mid) = messageId m - (Snowflake uid) = userId $ messageAuthor m + let (Snowflake cid) = unId $ messageChannelId m + (Snowflake mid) = unId $ messageId m + (Snowflake uid) = unId $ userId $ messageAuthor m added <- insert $ Reminder cid mid uid time content let res = pack $ show $ fromSqlKey added sendMessage m ("Reminder " <> res <> " set for " <> toTimestamp time <> " with message `" <> pack content <> "`") @@ -134,13 +131,13 @@ reminderCron = do let (Reminder cid mid uid _time content) = entityVal re in do liftIO . print $ entityVal re - res <- getMessage (Snowflake cid) (Snowflake mid) + res <- getMessage (DiscordId $ Snowflake cid) (DiscordId $ Snowflake mid) case res of Left _ -> do sendChannelMessage (fromIntegral cid) (pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content) delete (entityKey re) Right mess -> do - sendCustomReplyMessage mess (Snowflake mid) True $ + sendCustomReplyMessage mess (DiscordId $ Snowflake mid) True $ pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content delete (entityKey re) @@ -185,3 +182,6 @@ reminderPlugin = migrations = [reminderMigration], helpPages = [reminderHelp] } + +reminder :: CompiledPlugin +reminder = compilePlugin reminderPlugin diff --git a/src/Tablebot/Plugins/Roll.hs b/src/Tablebot/Plugins/Roll.hs index 8ff20b49..1616388e 100644 --- a/src/Tablebot/Plugins/Roll.hs +++ b/src/Tablebot/Plugins/Roll.hs @@ -7,6 +7,10 @@ -- Portability : POSIX -- -- A command that outputs the result of rolling the input dice. -module Tablebot.Plugins.Roll (rollPlugin) where +module Tablebot.Plugins.Roll (roll) where import Tablebot.Plugins.Roll.Plugin (rollPlugin) +import Tablebot.Utility + +roll :: CompiledPlugin +roll = compilePlugin rollPlugin diff --git a/src/Tablebot/Plugins/Roll/Dice.hs b/src/Tablebot/Plugins/Roll/Dice.hs index 06a4b0f8..365e44d2 100644 --- a/src/Tablebot/Plugins/Roll/Dice.hs +++ b/src/Tablebot/Plugins/Roll/Dice.hs @@ -9,39 +9,63 @@ -- This plugin contains the neccessary parsers and stucture to get the AST for an -- expression that contains dice, as well as evaluate that expression. -- --- The behind the scenes for the dice is split into four files. +-- The behind the scenes for the dice is split into six files, two of which +-- are for generating dice statistics. -- - DiceData - the data structures for the AST for dice -- - DiceFunctions - functionality for dealing with functions and processing -- them -- - DiceParsing - parsers for getting all the DiceData items -- - DiceEval - methods for evaluating elements from DiceData +-- - DiceStats - filling the type classes and function needed to generate +-- statistics on dice +-- - DiceStatsBase - functions to process dice value distributions -- -- Below is the regex representing the parsing for the expressions, and --- explanations for each component +-- explanations for each component. It's not 100% accurate to the actual data +-- representation, but it's close enough that you can start reading `DiceData`, +-- which is the canonical representation of the AST, and then DiceParsing. -- --- If there is a gap between terms, any number of spaces (including none) is valid, barring in lstv, dice, die, dopr, ords; spaces are added manually in those. +-- If there is a gap between terms, any number of spaces (including none) is +-- valid, barring in lstv, dice, die, dopr, ords, funcBasics, misc; spaces are +-- added manually in those. -- --- lstv - nbse "#" base | funcBasics | lstb +-- TODO: it's usually safer to put these kinds of grammars in Backus-Naur form +-- rather than regex due to the sheer number of regex standards and possible +-- overloading of ?. +-- +-- prog - stat* (lstv | expr) +-- stat - (lstv | expr) ";" +-- misc - ifst | vars +-- ifst - "if" spc1 expr spc1 "then" spc1 (lstv | expr) spc1 "else" spc1 (lstv | expr) +-- vars - "var" spc1 "!"? ("l_" name spcs "=" spcs lstv | name spcs "=" spcs expr) +-- lstv - nbse "#" base | funcBasics | lstb | name | misc -- lstb - "{" expr ("," expr)* "}" | "(" lstv ")" --- expr - term ([+-] expr)? +-- expr - term ([+-] expr)? | misc -- term - nega ([*/] term)? -- nega - "-" expo | expo -- expo - func "^" expo | func -- func - funcBasics | base --- base - dice | nbse +-- base - dice | nbse | name -- nbse - "(" expr ")" | [0-9]+ -- dice - base die dopr? --- die - "d" "!"? (bse | lstb) +-- die - "d" "!"? (base | lstb) -- dopr - dopo+ -- dopo - "!"? (("rr" | "ro") ords | ("k"|"d") (("l" | "h") nbse | "w" ords)) -- ords - ("/=" | "<=" | ">=" | "<" | "=" | ">") nbase -- spcs - " "* +-- spc1 - " "+ -- argv - lstv | expr --- funcBasics - {some string identifier} "(" (argv ("," argv)*)? ")" +-- funcBasics - {some string identifier} "(" spcs (argv (spcs "," spcs argv)*)? spcs ")" +-- name - [a-z_]* -- --- lstv (ListValues) - representing all possible list values (basic list values, functions that return lists, and values which are lists of length N that consist of `Base`s) +-- prog (Program) - representing a complete program - a series of statements and a value to output at the end. +-- stat (Statement) - representing a single statement - an expression or list value +-- misc (MiscData) - either an if or a var +-- ifst (If) - representing one of two values depending on the outcome of an expression +-- vars (Var) - setting a variable to a certain value +-- lstv (ListValues) - representing all possible list values (basic list values, functions that return lists, and values which are lists of length N that consist of `Base`s, as well as a MiscData value) -- lstb (ListValuesBase) - representing some basic list values (those that can be used in dice expressions, such as manually created lists and bracketed `ListValues`) --- expr (Expr) - representing addition, subtraction, or a single `Term` value +-- expr (Expr) - representing addition, subtraction, or a single `Term` value, or a MiscData value -- term (Term) - representing multiplication, division, or a single `Negation` value -- nega (Negation) - representing a negation, or a single `Expo` value -- expo (Expo) - representing exponentiation or a single `Func` value @@ -55,7 +79,7 @@ -- ords (AdvancedOrdering and NumBase) - representing a more complex ordering operation than a basic `Ordering`, when compared to a `NumBase` -- argv (ArgValue) - representing an argument to a function -- funcBasics - a generic regex representation for a general function parser -module Tablebot.Plugins.Roll.Dice (evalInteger, evalList, ListValues (..), defaultRoll, PrettyShow (prettyShow), integerFunctionsList, listFunctionsList, Converter (promote)) where +module Tablebot.Plugins.Roll.Dice (evalProgram, evalInteger, evalList, ListValues (..), defaultRoll, ParseShow (parseShow), integerFunctionsList, listFunctionsList, maximumListLength, maximumRNG, Converter (promote)) where import Tablebot.Plugins.Roll.Dice.DiceData ( Converter (promote), @@ -64,7 +88,7 @@ import Tablebot.Plugins.Roll.Dice.DiceData ListValues (..), NumBase (Value), ) -import Tablebot.Plugins.Roll.Dice.DiceEval (PrettyShow (prettyShow), evalInteger, evalList) +import Tablebot.Plugins.Roll.Dice.DiceEval (ParseShow (parseShow), evalInteger, evalList, evalProgram, maximumListLength, maximumRNG) import Tablebot.Plugins.Roll.Dice.DiceFunctions (integerFunctionsList, listFunctionsList) import Tablebot.Plugins.Roll.Dice.DiceParsing () diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceData.hs b/src/Tablebot/Plugins/Roll/Dice/DiceData.hs index 76c94efa..bb9d2e94 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceData.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceData.hs @@ -17,10 +17,37 @@ import Data.Text (Text) import Data.Tuple (swap) import Tablebot.Plugins.Roll.Dice.DiceFunctions (FuncInfo, FuncInfoBase) +-- | Set the variable `varName` to the value `varValue`. This also returns the +-- evaluated `varValue`. +-- +-- List variables have to be prefixed with `l_`. This really helps with parsing. +data Var a = Var {varName :: Text, varValue :: a} | VarLazy {varName :: Text, varValue :: a} deriving (Show) + +-- | If the first value is truthy (non-zero or a non-empty list) then return +-- the `thenValue`, else return the `elseValue`. +data If b = If {ifCond :: Expr, thenValue :: b, elseValue :: b} deriving (Show) + +-- | Either an If or a Var that returns a `b`. +data MiscData b = MiscIf (If b) | MiscVar (Var b) deriving (Show) + +-- | An expression is just an Expr or a ListValues with a semicolon on the end. +-- +-- When evaluating, VarLazy expressions are handled with a special case - they +-- are not evaluated until the value is first referenced. Otherwise, the value +-- is evaluated as the statement is encountered +data Statement = StatementExpr Expr | StatementListValues ListValues deriving (Show) + +-- | A program is a series of `Statement`s followed by either a `ListValues` or +-- an Expr. +data Program = Program [Statement] (Either ListValues Expr) deriving (Show) + -- | The value of an argument given to a function. data ArgValue = AVExpr Expr | AVListValues ListValues deriving (Show) +-- | Alias for `MiscData` that returns a `ListValues`. +type ListValuesMisc = MiscData ListValues + -- | The type for list values. data ListValues = -- | Represents `N#B`, where N is a NumBase (numbers, parentheses) and B is a Base (numbase or dice value) @@ -29,6 +56,10 @@ data ListValues LVFunc (FuncInfoBase [Integer]) [ArgValue] | -- | A base ListValues value - parentheses or a list of expressions LVBase ListValuesBase + | -- | A variable that has been defined elsewhere. + LVVar Text + | -- | A misc list values expression. + ListValuesMisc ListValuesMisc deriving (Show) -- | The type for basic list values (that can be used as is for custom dice). @@ -40,9 +71,12 @@ data ListValues data ListValuesBase = LVBParen (Paren ListValues) | LVBList [Expr] deriving (Show) +-- | Alias for `MiscData` that returns an `Expr`. +type ExprMisc = MiscData Expr + -- | The type of the top level expression. Represents one of addition, --- subtraction, or a single term. -data Expr = Add Term Expr | Sub Term Expr | NoExpr Term +-- subtraction, or a single term; or some misc expression statement. +data Expr = ExprMisc ExprMisc | Add Term Expr | Sub Term Expr | NoExpr Term deriving (Show) -- | The type representing multiplication, division, or a single negated term. @@ -70,7 +104,7 @@ newtype Paren a = Paren a deriving (Show) -- | The type representing a numeric base value value or a dice value. -data Base = NBase NumBase | DiceBase Dice +data Base = NBase NumBase | DiceBase Dice | NumVar Text deriving (Show) -- Dice Operations after this point @@ -176,3 +210,6 @@ instance Converter Dice Base where instance Converter Die Base where promote d = promote $ Dice (promote (1 :: Integer)) d Nothing + +instance Converter [Integer] ListValues where + promote = LVBase . LVBList . (promote <$>) diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs index d4a1b300..f2769102 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs @@ -8,46 +8,62 @@ -- -- Functions, type classes, and other utilities to evaluate dice values and -- expressions. -module Tablebot.Plugins.Roll.Dice.DiceEval (PrettyShow (prettyShow), evalList, evalInteger, evaluationException, propagateException) where +module Tablebot.Plugins.Roll.Dice.DiceEval (ParseShow (parseShow), evalProgram, evalList, evalInteger, evaluationException, propagateException, maximumRNG, maximumListLength) where -import Control.Monad (when) import Control.Monad.Exception (MonadException) -import Data.List (genericDrop, genericReplicate, genericTake, sortBy) +import Control.Monad.State (MonadIO (liftIO), StateT, evalStateT, gets, modify, when) +import Data.List (foldl', genericDrop, genericReplicate, genericTake, sortBy) import Data.List.NonEmpty as NE (NonEmpty ((:|)), head, tail, (<|)) -import Data.Map as M (findWithDefault) +import Data.Map (Map, empty) +import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing) -import Data.String (IsString (fromString)) import Data.Text (Text, intercalate, pack, unpack) -import qualified Data.Text as T import System.Random (randomRIO) import Tablebot.Plugins.Roll.Dice.DiceData import Tablebot.Plugins.Roll.Dice.DiceFunctions (FuncInfoBase (..), ListInteger (..)) +import Tablebot.Plugins.Roll.Dice.DiceParsing () import Tablebot.Utility.Discord (Format (..), formatInput, formatText) import Tablebot.Utility.Exception (BotException (EvaluationException), catchBot, throwBot) +import Tablebot.Utility.Parser (ParseShow (parseShow)) import Tablebot.Utility.Random (chooseOne) --- | A wrapper type to differentiate between the RNGCount and other Integers. +-- | A wrapper type to differentiate between the RNGCount and other Integers, +-- as well as store variables throughout the program. -- -- Represents the total number of calls to the RNG throughout the program -- (effectively, how many die rolls have occured). -newtype RNGCount = RNGCount {getRNGCount :: Integer} deriving (Eq, Ord) +data ProgramState = ProgramState + { getRNGCount :: Integer, + getVariables :: Map Text (Either ListValues Expr) + } + deriving (Show) + +startState :: ProgramState +startState = ProgramState 0 empty + +type ProgramStateM = StateT ProgramState IO + +-- | Add the given variable to the `ProgramState` +addVariable :: Text -> Either ListValues Expr -> ProgramStateM () +addVariable t val = modify $ \s -> s {getVariables = M.insert t val (getVariables s)} -- | The maximum depth that should be permitted. Used to limit number of dice -- and rerolls. -maximumRNG :: RNGCount -maximumRNG = RNGCount 150 +maximumRNG :: Integer +maximumRNG = 150 maximumListLength :: Integer maximumListLength = 50 -- | Increment the rngcount by 1. -incRNGCount :: RNGCount -> RNGCount -incRNGCount (RNGCount i) = RNGCount (i + 1) +incRNGCount :: ProgramStateM () +incRNGCount = modify (\s -> s {getRNGCount = getRNGCount s + 1}) >> checkRNGCount -- | Check whether the RNG count has been exceeded by the integer given. -checkRNGCount :: RNGCount -> IO () -checkRNGCount i = - when (i > maximumRNG) $ throwBot $ EvaluationException ("exceeded maximum rng count (" <> show (getRNGCount maximumRNG) <> ")") [] +checkRNGCount :: ProgramStateM () +checkRNGCount = do + rngCount <- gets getRNGCount + when (rngCount > maximumRNG) $ evaluationException ("Maximum RNG count exceeded (" <> pack (show maximumRNG) <> ")") [] -- | Utility function to throw an `EvaluationException` when using `Text`. evaluationException :: (MonadException m) => Text -> [Text] -> m a @@ -55,24 +71,44 @@ evaluationException nm locs = throwBot $ EvaluationException (unpack nm) (unpack --- Evaluating an expression. Uses IO because dice are random +-- | Evaluating a full program +evalProgram :: Program -> IO (Either [(Integer, Text)] Integer, Text) +evalProgram (Program ss elve) = + evalStateT + ( do + -- evaluate all the statements + stmts <- foldl' folder (return "") ss + -- evaluate the expression + r <- either ((Left <$>) . evalShowL) ((Right <$>) . evalShow) elve + case r of + Left (is, mtxt) -> return (Left is, stmts <> fromMaybe (parseShow elve) mtxt) + Right (i, txt) -> return (Right i, stmts <> txt) + ) + startState + where + folder b s = do + stmts <- b + st <- evalStatement s + return (stmts <> st) + -- | Given a list expression, evaluate it, getting the pretty printed string and -- the value of the result. -evalList :: (IOEvalList a, PrettyShow a) => a -> IO ([(Integer, Text)], Text) +evalList :: (IOEvalList a, ParseShow a) => a -> IO ([(Integer, Text)], Text) evalList a = do - (is, ss, _) <- evalShowL (RNGCount 0) a - return (is, fromMaybe (prettyShow a) ss) + (is, ss) <- evalStateT (evalShowL a) startState + return (is, fromMaybe (parseShow a) ss) -- | Given an integer expression, evaluate it, getting the pretty printed string -- and the value of the result. -evalInteger :: (IOEval a, PrettyShow a) => a -> IO (Integer, Text) +evalInteger :: (IOEval a, ParseShow a) => a -> IO (Integer, Text) evalInteger a = do - (is, ss, _) <- evalShow (RNGCount 0) a + (is, ss) <- evalStateT (evalShow a) startState return (is, ss) -- | Utility function to display dice. -- -- The tuple of integers denotes what the critvalues of this dice value are. The --- `a` denotes the value that is being printed, and needs to have `PrettyShow` +-- `a` denotes the value that is being printed, and needs to have `ParseShow` -- defined for it. -- -- Finally, the list of tuples denotes all the values that the `a` value has @@ -80,9 +116,9 @@ evalInteger a = do -- as normal. If the value is `Just False`, the value has been rerolled over, -- and is displayed crossed out. If the value is `Just True`, the value has been -- dropped, and the number is crossed out and underlined. -dieShow :: (PrettyShow a, MonadException m) => Maybe (Integer, Integer) -> a -> [(Integer, Maybe Bool)] -> m Text -dieShow _ a [] = evaluationException "tried to show empty set of results" [prettyShow a] -dieShow lchc d ls = return $ prettyShow d <> " [" <> intercalate ", " adjustList <> "]" +dieShow :: (ParseShow a, MonadException m) => Maybe (Integer, Integer) -> a -> [(Integer, Maybe Bool)] -> m Text +dieShow _ a [] = evaluationException "tried to show empty set of results" [parseShow a] +dieShow lchc d ls = return $ parseShow d <> " [" <> intercalate ", " adjustList <> "]" where toCrit = pack @@ -100,25 +136,25 @@ dieShow lchc d ls = return $ prettyShow d <> " [" <> intercalate ", " adjustList -- | Evaluate a series of values, combining the text output into a comma -- separated list. -evalShowList :: (IOEval a, PrettyShow a) => RNGCount -> [a] -> IO ([Integer], Text, RNGCount) -evalShowList rngCount as = do - (vs, rngCount') <- evalShowList' rngCount as +evalShowList :: (IOEval a, ParseShow a) => [a] -> ProgramStateM ([Integer], Text) +evalShowList as = do + vs <- evalShowList' as let (is, ts) = unzip vs - return (is, intercalate ", " ts, rngCount') + return (is, intercalate ", " ts) -- | Evaluate a series of values, combining the text output a list. -evalShowList' :: (IOEval a, PrettyShow a) => RNGCount -> [a] -> IO ([(Integer, Text)], RNGCount) +evalShowList' :: (IOEval a, ParseShow a) => [a] -> ProgramStateM [(Integer, Text)] evalShowList' = evalShowList'' evalShow -- | Evaluate (using a custom evaluator function) a series of values, getting -- strings and values as a result. -evalShowList'' :: (RNGCount -> a -> IO (i, Text, RNGCount)) -> RNGCount -> [a] -> IO ([(i, Text)], RNGCount) -evalShowList'' customEvalShow rngCount = foldr foldF (return ([], rngCount)) +evalShowList'' :: (a -> ProgramStateM (i, Text)) -> [a] -> ProgramStateM [(i, Text)] +evalShowList'' customEvalShow as = foldl' (flip foldF) (return []) as >>= \lst -> return (reverse lst) where foldF a sumrngcount = do - (diceSoFar, rngCountTotal) <- sumrngcount - (i, s, rngCountTemp) <- customEvalShow rngCountTotal a - return ((i, s) : diceSoFar, rngCountTemp) + diceSoFar <- sumrngcount + (i, s) <- customEvalShow a + return ((i, s) : diceSoFar) -- | When given a value that may possibly have an `EvaluationException`, add the -- representation of the current value to the exception stack. @@ -138,34 +174,44 @@ class IOEvalList a where -- it took. If the `a` value is a dice value, the values of the dice should be -- displayed. This function adds the current location to the exception -- callstack. - evalShowL :: PrettyShow a => RNGCount -> a -> IO ([(Integer, Text)], Maybe Text, RNGCount) - evalShowL rngCount a = do - (is, mt, rngCount') <- propagateException (prettyShow a) (evalShowL' rngCount a) - return (genericTake maximumListLength is, mt, rngCount') + evalShowL :: ParseShow a => a -> ProgramStateM ([(Integer, Text)], Maybe Text) + evalShowL a = do + (is, mt) <- propagateException (parseShow a) (evalShowL' a) + return (genericTake maximumListLength is, mt) - evalShowL' :: PrettyShow a => RNGCount -> a -> IO ([(Integer, Text)], Maybe Text, RNGCount) + evalShowL' :: ParseShow a => a -> ProgramStateM ([(Integer, Text)], Maybe Text) -evalArgValue :: RNGCount -> ArgValue -> IO (ListInteger, RNGCount) -evalArgValue rngCount (AVExpr e) = do - (i, _, rngCount') <- evalShow rngCount e - return (LIInteger i, rngCount') -evalArgValue rngCount (AVListValues e) = do - (i, _, rngCount') <- evalShowL rngCount e - return (LIList (fst <$> i), rngCount') +evalArgValue :: ArgValue -> ProgramStateM ListInteger +evalArgValue (AVExpr e) = do + (i, _) <- evalShow e + return $ LIInteger i +evalArgValue (AVListValues e) = do + (i, _) <- evalShowL e + return (LIList (fst <$> i)) instance IOEvalList ListValues where - evalShowL' rngCount (MultipleValues nb b) = do - (nb', _, rngCount') <- evalShow rngCount nb - (vs, rc) <- evalShowList' rngCount' (genericReplicate nb' b) - return (vs, Nothing, rc) - evalShowL' rngCount (LVFunc fi exprs) = evaluateFunction rngCount fi exprs >>= \(i, s, rc) -> return ((,"") <$> i, Just s, rc) - evalShowL' rngCount (LVBase lvb) = evalShowL rngCount lvb + evalShowL' (MultipleValues nb b) = do + (nb', _) <- evalShow nb + vs <- evalShowList' (genericReplicate nb' b) + return (vs, Nothing) + evalShowL' (LVFunc fi exprs) = evaluateFunction fi exprs >>= \(i, s) -> return ((,"") <$> i, Just s) + evalShowL' (LVBase lvb) = evalShowL lvb + evalShowL' (LVVar t) = do + vars <- gets getVariables + case M.lookup t vars of + Just (Left e) -> evalShowL e >>= \(i, _) -> return (i, Just t) + _ -> evaluationException ("could not find list variable `" <> t <> "`") [] + evalShowL' (ListValuesMisc l) = evalShowL l instance IOEvalList ListValuesBase where - evalShowL' rngCount (LVBList es) = do - (vs, rc) <- evalShowList' rngCount es - return (vs, Nothing, rc) - evalShowL' rngCount (LVBParen (Paren lv)) = evalShowL rngCount lv + evalShowL' (LVBList es) = do + vs <- evalShowList' es + return (vs, Nothing) + evalShowL' (LVBParen (Paren lv)) = evalShowL lv + +instance IOEvalList ListValuesMisc where + evalShowL' (MiscVar l) = evalShowL l + evalShowL' (MiscIf l) = evalShowL l -- | This type class gives a function which evaluates the value to an integer -- and a string. @@ -174,48 +220,53 @@ class IOEval a where -- value, and the number of RNG calls it took. If the `a` value is a dice -- value, the values of the dice should be displayed. This function adds -- the current location to the exception callstack. - evalShow :: PrettyShow a => RNGCount -> a -> IO (Integer, Text, RNGCount) - evalShow rngCount a = propagateException (prettyShow a) (evalShow' rngCount a) + evalShow :: ParseShow a => a -> ProgramStateM (Integer, Text) + evalShow a = propagateException (parseShow a) (evalShow' a) - evalShow' :: PrettyShow a => RNGCount -> a -> IO (Integer, Text, RNGCount) + evalShow' :: ParseShow a => a -> ProgramStateM (Integer, Text) instance IOEval Base where - evalShow' rngCount (NBase nb) = evalShow rngCount nb - evalShow' rngCount (DiceBase dice) = evalShow rngCount dice + evalShow' (NBase nb) = evalShow nb + evalShow' (DiceBase dice) = evalShow dice + evalShow' (NumVar t) = do + vars <- gets getVariables + case M.lookup t vars of + Just (Right e) -> evalShow e >>= \(i, _) -> return (i, t) + _ -> evaluationException ("could not find integer variable `" <> t <> "`") [] instance IOEval Die where - evalShow' rngCount ld@(LazyDie d) = do - (i, _, rngCount') <- evalShow rngCount d + evalShow' ld@(LazyDie d) = do + (i, _) <- evalShow d ds <- dieShow Nothing ld [(i, Nothing)] - return (i, ds, rngCount') - evalShow' rngCount d@(CustomDie (LVBList es)) = do - e <- chooseOne es - (i, _, rngCount') <- evalShow rngCount e + return (i, ds) + evalShow' d@(CustomDie (LVBList es)) = do + e <- liftIO $ chooseOne es + (i, _) <- evalShow e ds <- dieShow Nothing d [(i, Nothing)] - checkRNGCount (incRNGCount rngCount') - return (i, ds, incRNGCount rngCount') - evalShow' rngCount d@(CustomDie is) = do - (is', _, rngCount') <- evalShowL rngCount is - i <- chooseOne (fst <$> is') + incRNGCount + return (i, ds) + evalShow' d@(CustomDie is) = do + (is', _) <- evalShowL is + i <- liftIO $ chooseOne (fst <$> is') ds <- dieShow Nothing d [(i, Nothing)] - checkRNGCount (incRNGCount rngCount') - return (i, ds, incRNGCount rngCount') - evalShow' rngCount d@(Die b) = do - (bound, _, rngCount') <- evalShow rngCount b + incRNGCount + return (i, ds) + evalShow' d@(Die b) = do + (bound, _) <- evalShow b if bound < 1 - then evaluationException ("Cannot roll a < 1 sided die (" <> formatText Code (prettyShow b) <> ")") [] + then evaluationException ("Cannot roll a < 1 sided die (" <> formatText Code (parseShow b) <> ")") [] else do i <- randomRIO (1, bound) ds <- dieShow Nothing d [(i, Nothing)] - checkRNGCount (incRNGCount rngCount') - return (i, ds, incRNGCount rngCount') + incRNGCount + return (i, ds) instance IOEval Dice where - evalShow' rngCount dop = do - (lst, mnmx, rngCount') <- evalDieOp rngCount dop + evalShow' dop = do + (lst, mnmx) <- evalDieOp dop let vs = fromEvalDieOpList lst s <- dieShow mnmx dop vs - return (sum (fst <$> filter (isNothing . snd) vs), s, rngCount') + return (sum (fst <$> filter (isNothing . snd) vs), s) -- | Utility function to transform the output list type of other utility -- functions into one that `dieShow` recognises. @@ -231,76 +282,76 @@ fromEvalDieOpList = foldr foldF [] -- -- The function itself checks to make sure the number of dice being rolled is -- less than the maximum recursion and is non-negative. -evalDieOp :: RNGCount -> Dice -> IO ([(NonEmpty Integer, Bool)], Maybe (Integer, Integer), RNGCount) -evalDieOp rngCount (Dice b ds dopo) = do - (nbDice, _, rngCountB) <- evalShow rngCount b - if RNGCount nbDice > maximumRNG - then evaluationException ("tried to roll more than " <> formatInput Code (getRNGCount maximumRNG) <> " dice: " <> formatInput Code nbDice) [prettyShow b] +evalDieOp :: Dice -> ProgramStateM ([(NonEmpty Integer, Bool)], Maybe (Integer, Integer)) +evalDieOp (Dice b ds dopo) = do + (nbDice, _) <- evalShow b + if nbDice > maximumRNG + then evaluationException ("tried to roll more than " <> formatInput Code maximumRNG <> " dice: " <> formatInput Code nbDice) [parseShow b] else do if nbDice < 0 - then evaluationException ("tried to give a negative value to the number of dice: " <> formatInput Code nbDice) [prettyShow b] + then evaluationException ("tried to give a negative value to the number of dice: " <> formatInput Code nbDice) [parseShow b] else do - (ds', rngCountCondense, crits) <- condenseDie rngCountB ds - (rolls, _, rngCountRolls) <- evalShowList rngCountCondense (genericReplicate nbDice ds') + (ds', crits) <- condenseDie ds + (rolls, _) <- evalShowList (genericReplicate nbDice ds') let vs = fmap (\i -> (i :| [], True)) rolls - (rs, rngCountRs) <- evalDieOp' rngCountRolls dopo ds' vs - return (sortBy sortByOption rs, crits, rngCountRs) + rs <- evalDieOp' dopo ds' vs + return (sortBy sortByOption rs, crits) where - condenseDie rngCount' (Die dBase) = do - (i, _, rngCount'') <- evalShow rngCount' dBase - return (Die (Value i), rngCount'', Just (1, i)) - condenseDie rngCount' (CustomDie is) = do - (is', _, rngCount'') <- evalShowL rngCount' is - return (CustomDie (LVBList (promote . fst <$> is')), rngCount'', Nothing) - condenseDie rngCount' (LazyDie d) = return (d, rngCount', Nothing) + condenseDie (Die dBase) = do + (i, _) <- evalShow dBase + return (Die (Value i), Just (1, i)) + condenseDie (CustomDie is) = do + (is', _) <- evalShowL is + return (CustomDie (LVBList (promote . fst <$> is')), Nothing) + condenseDie (LazyDie d) = return (d, Nothing) sortByOption (e :| es, _) (f :| fs, _) | e == f = compare (length fs) (length es) | otherwise = compare e f -- | Utility function that processes a `Maybe DieOpRecur`, when given a die, and -- dice that have already been processed. -evalDieOp' :: RNGCount -> Maybe DieOpRecur -> Die -> [(NonEmpty Integer, Bool)] -> IO ([(NonEmpty Integer, Bool)], RNGCount) -evalDieOp' rngCount Nothing _ is = return (is, rngCount) -evalDieOp' rngCount (Just (DieOpRecur doo mdor)) die is = do - (doo', rngCount') <- processDOO rngCount doo - (is', rngCount'') <- evalDieOp'' rngCount' doo' die is - evalDieOp' rngCount'' mdor die is' +evalDieOp' :: Maybe DieOpRecur -> Die -> [(NonEmpty Integer, Bool)] -> ProgramStateM [(NonEmpty Integer, Bool)] +evalDieOp' Nothing _ is = return is +evalDieOp' (Just (DieOpRecur doo mdor)) die is = do + doo' <- processDOO doo + is' <- evalDieOp'' doo' die is + evalDieOp' mdor die is' where - processLHW rngCount' (Low i) = do - (i', _, rngCount'') <- evalShow rngCount' i - return (Low (Value i'), rngCount'') - processLHW rngCount' (High i) = do - (i', _, rngCount'') <- evalShow rngCount' i - return (High (Value i'), rngCount'') - processLHW rngCount' (Where o i) = do - (i', _, rngCount'') <- evalShow rngCount' i - return (Where o (Value i'), rngCount'') - processDOO rngCount' (DieOpOptionKD kd lhw) = do - (lhw', rngCount'') <- processLHW rngCount' lhw - return (DieOpOptionKD kd lhw', rngCount'') - processDOO rngCount' (Reroll once o i) = do - (i', _, rngCount'') <- evalShow rngCount' i - return (Reroll once o (Value i'), rngCount'') - processDOO rngCount' (DieOpOptionLazy doo') = return (doo', rngCount') + processLHW (Low i) = do + (i', _) <- evalShow i + return (Low (Value i')) + processLHW (High i) = do + (i', _) <- evalShow i + return (High (Value i')) + processLHW (Where o i) = do + (i', _) <- evalShow i + return (Where o (Value i')) + processDOO (DieOpOptionKD kd lhw) = do + lhw' <- processLHW lhw + return (DieOpOptionKD kd lhw') + processDOO (Reroll once o i) = do + (i', _) <- evalShow i + return (Reroll once o (Value i')) + processDOO (DieOpOptionLazy doo') = return doo' -- | Utility function that processes a `DieOpOption`, when given a die, and dice -- that have already been processed. -evalDieOp'' :: RNGCount -> DieOpOption -> Die -> [(NonEmpty Integer, Bool)] -> IO ([(NonEmpty Integer, Bool)], RNGCount) -evalDieOp'' rngCount (DieOpOptionLazy doo) die is = evalDieOp'' rngCount doo die is -evalDieOp'' rngCount (DieOpOptionKD kd lhw) _ is = evalDieOpHelpKD rngCount kd lhw is -evalDieOp'' rngCount (Reroll once o i) die is = foldr rerollF (return ([], rngCount)) is +evalDieOp'' :: DieOpOption -> Die -> [(NonEmpty Integer, Bool)] -> ProgramStateM [(NonEmpty Integer, Bool)] +evalDieOp'' (DieOpOptionLazy doo) die is = evalDieOp'' doo die is +evalDieOp'' (DieOpOptionKD kd lhw) _ is = evalDieOpHelpKD kd lhw is +evalDieOp'' (Reroll once o i) die is = foldr rerollF (return []) is where rerollF g@(i', b) isRngCount' = do - (is', rngCount') <- isRngCount' - (iEval, _, rngCount'') <- evalShow rngCount' i + is' <- isRngCount' + (iEval, _) <- evalShow i if b && applyCompare o (NE.head i') iEval then do - (v, _, rngCount''') <- evalShow rngCount'' die + (v, _) <- evalShow die let ret = (v <| i', b) if once - then return (ret : is', rngCount''') - else rerollF ret (return (is', rngCount''')) - else return (g : is', rngCount'') + then return (ret : is') + else rerollF ret (return is') + else return (g : is') -- | Given a list of dice values, separate them into kept values and dropped values -- respectively. @@ -315,17 +366,17 @@ setToDropped :: [(NonEmpty Integer, Bool)] -> [(NonEmpty Integer, Bool)] setToDropped = fmap (\(is, _) -> (is, False)) -- | Helper function that executes the keep/drop commands on dice. -evalDieOpHelpKD :: RNGCount -> KeepDrop -> LowHighWhere -> [(NonEmpty Integer, Bool)] -> IO ([(NonEmpty Integer, Bool)], RNGCount) -evalDieOpHelpKD rngCount kd (Where cmp i) is = foldr foldF (return ([], rngCount)) is +evalDieOpHelpKD :: KeepDrop -> LowHighWhere -> [(NonEmpty Integer, Bool)] -> ProgramStateM [(NonEmpty Integer, Bool)] +evalDieOpHelpKD kd (Where cmp i) is = foldr foldF (return []) is where isKeep = if kd == Keep then id else not foldF (iis, b) sumrngcount = do - (diceSoFar, rngCountTotal) <- sumrngcount - (i', _, rngCountTemp) <- evalShow rngCountTotal i - return ((iis, b && isKeep (applyCompare cmp (NE.head iis) i')) : diceSoFar, rngCountTemp) -evalDieOpHelpKD rngCount kd lh is = do - (i', _, rngCount') <- evalShow rngCount i - return (d <> setToDropped (getDrop i' sk) <> getKeep i' sk, rngCount') + diceSoFar <- sumrngcount + (i', _) <- evalShow i + return ((iis, b && isKeep (applyCompare cmp (NE.head iis) i')) : diceSoFar) +evalDieOpHelpKD kd lh is = do + (i', _) <- evalShow i + return (d <> setToDropped (getDrop i' sk) <> getKeep i' sk) where (k, d) = separateKeptDropped is -- Note that lh will always be one of `Low` or `High` @@ -338,135 +389,109 @@ evalDieOpHelpKD rngCount kd lh is = do -- Was previously its own type class that wouldn't work for evaluating Base values. -- | Utility function to evaluate a binary operator. -binOpHelp :: (IOEval a, IOEval b, PrettyShow a, PrettyShow b) => RNGCount -> a -> b -> Text -> (Integer -> Integer -> Integer) -> IO (Integer, Text, RNGCount) -binOpHelp rngCount a b opS op = do - (a', a's, rngCount') <- evalShow rngCount a - (b', b's, rngCount'') <- evalShow rngCount' b - return (op a' b', a's <> " " <> opS <> " " <> b's, rngCount'') +binOpHelp :: (IOEval a, IOEval b, ParseShow a, ParseShow b) => a -> b -> Text -> (Integer -> Integer -> Integer) -> ProgramStateM (Integer, Text) +binOpHelp a b opS op = do + (a', a's) <- evalShow a + (b', b's) <- evalShow b + return (op a' b', a's <> " " <> opS <> " " <> b's) + +instance IOEval ExprMisc where + evalShow' (MiscVar l) = evalShow l + evalShow' (MiscIf l) = evalShow l instance IOEval Expr where - evalShow' rngCount (NoExpr t) = evalShow rngCount t - evalShow' rngCount (Add t e) = binOpHelp rngCount t e "+" (+) - evalShow' rngCount (Sub t e) = binOpHelp rngCount t e "-" (-) + evalShow' (NoExpr t) = evalShow t + evalShow' (ExprMisc e) = evalShow e + evalShow' (Add t e) = binOpHelp t e "+" (+) + evalShow' (Sub t e) = binOpHelp t e "-" (-) instance IOEval Term where - evalShow' rngCount (NoTerm f) = evalShow rngCount f - evalShow' rngCount (Multi f t) = binOpHelp rngCount f t "*" (*) - evalShow' rngCount (Div f t) = do - (f', f's, rngCount') <- evalShow rngCount f - (t', t's, rngCount'') <- evalShow rngCount' t + evalShow' (NoTerm f) = evalShow f + evalShow' (Multi f t) = binOpHelp f t "*" (*) + evalShow' (Div f t) = do + (f', f's) <- evalShow f + (t', t's) <- evalShow t if t' == 0 - then evaluationException "division by zero" [prettyShow t] - else return (div f' t', f's <> " / " <> t's, rngCount'') + then evaluationException "division by zero" [parseShow t] + else return (div f' t', f's <> " / " <> t's) instance IOEval Func where - evalShow' rngCount (Func s exprs) = evaluateFunction rngCount s exprs - evalShow' rngCount (NoFunc b) = evalShow rngCount b + evalShow' (Func s exprs) = evaluateFunction s exprs + evalShow' (NoFunc b) = evalShow b -- | Evaluate a function when given a list of parameters -evaluateFunction :: RNGCount -> FuncInfoBase j -> [ArgValue] -> IO (j, Text, RNGCount) -evaluateFunction rngCount fi exprs = do - (exprs', rngCount') <- evalShowList'' (\r a -> evalArgValue r a >>= \(i, r') -> return (i, "", r')) rngCount exprs +evaluateFunction :: FuncInfoBase j -> [ArgValue] -> ProgramStateM (j, Text) +evaluateFunction fi exprs = do + exprs' <- evalShowList'' (fmap (,"") . evalArgValue) exprs f <- funcInfoFunc fi (fst <$> exprs') - return (f, funcInfoName fi <> "(" <> intercalate ", " (prettyShow <$> exprs) <> ")", rngCount') + return (f, funcInfoName fi <> "(" <> intercalate ", " (parseShow <$> exprs) <> ")") instance IOEval Negation where - evalShow' rngCount (NoNeg expo) = evalShow rngCount expo - evalShow' rngCount (Neg expo) = do - (expo', expo's, rngCount') <- evalShow rngCount expo - return (negate expo', "-" <> expo's, rngCount') + evalShow' (NoNeg expo) = evalShow expo + evalShow' (Neg expo) = do + (expo', expo's) <- evalShow expo + return (negate expo', "-" <> expo's) instance IOEval Expo where - evalShow' rngCount (NoExpo b) = evalShow rngCount b - evalShow' rngCount (Expo b expo) = do - (expo', expo's, rngCount') <- evalShow rngCount expo + evalShow' (NoExpo b) = evalShow b + evalShow' (Expo b expo) = do + (expo', expo's) <- evalShow expo if expo' < 0 - then evaluationException ("the exponent is negative: " <> formatInput Code expo') [prettyShow expo] + then evaluationException ("the exponent is negative: " <> formatInput Code expo') [parseShow expo] else do - (b', b's, rngCount'') <- evalShow rngCount' b - return (b' ^ expo', b's <> " ^ " <> expo's, rngCount'') + (b', b's) <- evalShow b + return (b' ^ expo', b's <> " ^ " <> expo's) instance IOEval NumBase where - evalShow' rngCount (NBParen (Paren e)) = do - (r, s, rngCount') <- evalShow rngCount e - return (r, "(" <> s <> ")", rngCount') - evalShow' rngCount (Value i) = return (i, pack (show i), rngCount) - ---- Pretty printing the AST --- The output from this should be parseable - --- | Type class to display an expression prettily (not neccessarily accurately). -class PrettyShow a where - -- | Print the given value prettily. - prettyShow :: a -> Text - -instance PrettyShow ArgValue where - prettyShow (AVExpr e) = prettyShow e - prettyShow (AVListValues lv) = prettyShow lv - -instance PrettyShow ListValues where - prettyShow (LVBase e) = prettyShow e - prettyShow (MultipleValues nb b) = prettyShow nb <> "#" <> prettyShow b - prettyShow (LVFunc s n) = funcInfoName s <> "(" <> intercalate "," (prettyShow <$> n) <> ")" - -instance PrettyShow ListValuesBase where - prettyShow (LVBList es) = "{" <> intercalate ", " (prettyShow <$> es) <> "}" - prettyShow (LVBParen p) = prettyShow p - -instance PrettyShow Expr where - prettyShow (Add t e) = prettyShow t <> " + " <> prettyShow e - prettyShow (Sub t e) = prettyShow t <> " - " <> prettyShow e - prettyShow (NoExpr t) = prettyShow t - -instance PrettyShow Term where - prettyShow (Multi f t) = prettyShow f <> " * " <> prettyShow t - prettyShow (Div f t) = prettyShow f <> " / " <> prettyShow t - prettyShow (NoTerm f) = prettyShow f - -instance PrettyShow Func where - prettyShow (Func s n) = funcInfoName s <> "(" <> intercalate "," (prettyShow <$> n) <> ")" - prettyShow (NoFunc b) = prettyShow b - -instance PrettyShow Negation where - prettyShow (Neg expo) = "-" <> prettyShow expo - prettyShow (NoNeg expo) = prettyShow expo - -instance PrettyShow Expo where - prettyShow (NoExpo b) = prettyShow b - prettyShow (Expo b expo) = prettyShow b <> " ^ " <> prettyShow expo - -instance PrettyShow NumBase where - prettyShow (NBParen p) = prettyShow p - prettyShow (Value i) = fromString $ show i - -instance (PrettyShow a) => PrettyShow (Paren a) where - prettyShow (Paren a) = "(" <> prettyShow a <> ")" - -instance PrettyShow Base where - prettyShow (NBase nb) = prettyShow nb - prettyShow (DiceBase dop) = prettyShow dop - -instance PrettyShow Die where - prettyShow (Die b) = "d" <> prettyShow b - prettyShow (CustomDie lv) = "d" <> prettyShow lv - -- prettyShow (CustomDie is) = "d{" <> intercalate ", " (prettyShow <$> is) <> "}" - prettyShow (LazyDie d) = "d!" <> T.tail (prettyShow d) - -instance PrettyShow Dice where - prettyShow (Dice b d dor) = prettyShow b <> prettyShow d <> helper' dor - where - fromOrdering ao = M.findWithDefault "??" ao $ snd advancedOrderingMapping - fromLHW (Where o i) = "w" <> fromOrdering o <> prettyShow i - fromLHW (Low i) = "l" <> prettyShow i - fromLHW (High i) = "h" <> prettyShow i - helper' Nothing = "" - helper' (Just (DieOpRecur dopo' dor')) = helper dopo' <> helper' dor' - helper (DieOpOptionLazy doo) = "!" <> helper doo - helper (Reroll True o i) = "ro" <> fromOrdering o <> prettyShow i - helper (Reroll False o i) = "rr" <> fromOrdering o <> prettyShow i - helper (DieOpOptionKD Keep lhw) = "k" <> fromLHW lhw - helper (DieOpOptionKD Drop lhw) = "d" <> fromLHW lhw - -instance (PrettyShow a, PrettyShow b) => PrettyShow (Either a b) where - prettyShow (Left a) = prettyShow a - prettyShow (Right b) = prettyShow b + evalShow' (NBParen (Paren e)) = do + (r, s) <- evalShow e + return (r, "(" <> s <> ")") + evalShow' (Value i) = return (i, pack (show i)) + +instance IOEval (Var Expr) where + evalShow' (Var t a) = do + (v, lt) <- evalShow a + addVariable t (Right $ promote v) + return (v, "var " <> t <> " = " <> lt) + evalShow' l@(VarLazy t a) = do + (v, _) <- evalShow a + addVariable t (Right a) + return $ v `seq` (v, parseShow l) + +instance IOEvalList (Var ListValues) where + evalShowL' l@(Var t a) = do + (v, _) <- evalShowL a + addVariable t (Left $ promote $ fst <$> v) + return (v, Just (parseShow l)) + evalShowL' l@(VarLazy t a) = do + (v, _) <- evalShowL a + addVariable t (Left a) + return (v, Just (parseShow l)) + +evalStatement :: Statement -> ProgramStateM Text +evalStatement (StatementExpr l) = evalShowStatement l >>= \(_, t) -> return (t <> "; ") + where + evalShowStatement (ExprMisc (MiscVar l'@(VarLazy t a))) = addVariable t (Right a) >> return (0, parseShow l') + evalShowStatement l' = evalShow l' +evalStatement (StatementListValues l) = evalShowStatement l >>= \(_, t) -> return (fromMaybe (parseShow l) t <> "; ") + where + evalShowStatement (ListValuesMisc (MiscVar l'@(VarLazy t a))) = addVariable t (Left a) >> return ([], Just (parseShow l')) + evalShowStatement l' = evalShowL l' + +instance IOEval (If Expr) where + evalShow' if'@(If b t e) = do + (i, _) <- evalShow b + (i', _) <- + if i /= 0 + then evalShow t + else evalShow e + return (i', parseShow if') + +instance IOEvalList (If ListValues) where + evalShowL' if'@(If b t e) = do + (i, _) <- evalShow b + (i', _) <- + if i /= 0 + then evalShowL t + else evalShowL e + return (i', Just $ parseShow if') diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs b/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs index b24dbd8b..e85b1b0d 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs @@ -21,9 +21,10 @@ module Tablebot.Plugins.Roll.Dice.DiceFunctions where import Control.Monad.Exception (MonadException) -import Data.List (genericDrop, genericLength, genericTake, sort) +import Data.List (genericDrop, genericLength, genericReplicate, genericTake, sort) import Data.Map as M (Map, fromList, keys) import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) import Data.Text (Text, unpack) import Tablebot.Utility.Exception (BotException (EvaluationException), throwBot) @@ -76,6 +77,10 @@ listFunctionsList = M.keys listFunctions -- each function that returns an integer. listFunctions' :: [FuncInfoBase [Integer]] listFunctions' = + funcInfoInsert : + constructFuncInfo "prepend" (:) : + constructFuncInfo "replicate" (genericReplicate @Integer) : + funcInfoSet : constructFuncInfo "concat" (++) : constructFuncInfo "between" between : constructFuncInfo "drop" (genericDrop @Integer) : @@ -85,13 +90,39 @@ listFunctions' = between i i' = let (mi, ma, rev) = (min i i', max i i', if i > i' then reverse else id) in rev [mi .. ma] -- | The `FuncInfo` of the function that indexes into a list. +-- +-- Creates a function that takes an integer and a list and returns an integer. funcInfoIndex :: FuncInfo funcInfoIndex = FuncInfo "index" [ATInteger, ATIntegerList] ATInteger fiIndex where fiIndex (LIInteger i : [LIList is]) | i < 0 || i >= genericLength is = throwBot $ EvaluationException ("index out of range: " ++ show i) [] | otherwise = return (is !! fromInteger i) - fiIndex is = throwBot $ EvaluationException ("incorrect number of arguments. expected 2, got " ++ show (length is)) [] + fiIndex is = throwBot $ EvaluationException ("incorrect number/type of arguments. expected 2, got " ++ show (length is)) [] + +-- | The `FuncInfo` of the function that sets an element in a list. +-- +-- Creates a function that takes an index, an integer and a list and returns a +-- list. +funcInfoSet :: FuncInfoBase [Integer] +funcInfoSet = FuncInfo "set" [ATInteger, ATInteger, ATIntegerList] ATIntegerList fiSet + where + fiSet (LIInteger i : LIInteger j : [LIList js]) + | i < 0 || i >= genericLength js = throwBot $ EvaluationException ("index out of range: " ++ show i) [] + | otherwise = return $ genericTake i js ++ j : genericDrop (i + 1) js + fiSet is = throwBot $ EvaluationException ("incorrect number/type of arguments. expected 3, got " ++ show (length is)) [] + +-- | The `FuncInfo` of the function that inserts an integer into a list. +-- +-- Creates a function that takes an index, an integer and a list and returns a +-- list. +funcInfoInsert :: FuncInfoBase [Integer] +funcInfoInsert = FuncInfo "insert" [ATInteger, ATInteger, ATIntegerList] ATIntegerList fiSet + where + fiSet (LIInteger i : LIInteger j : [LIList js]) + | i < 0 || i >= genericLength js = throwBot $ EvaluationException ("index out of range: " ++ show i) [] + | otherwise = return $ genericTake i js ++ j : genericDrop i js + fiSet is = throwBot $ EvaluationException ("incorrect number/type of arguments. expected 3, got " ++ show (length is)) [] -- | A data structure to contain the information about a given function, -- including types, the function name, and the function itself. @@ -111,7 +142,7 @@ constructFuncInfo s f = constructFuncInfo' s f (Nothing, Nothing, const False) constructFuncInfo' :: forall j f. (ApplyFunc f, Returns f ~ j) => Text -> f -> (Maybe Integer, Maybe Integer, Integer -> Bool) -> FuncInfoBase j constructFuncInfo' s f bs = FuncInfo s params (last types) (applyFunc f (fromIntegral (length params)) bs) where - types = getTypes f + types = getTypes (Proxy :: Proxy f) params = init types -- | Some evaluated values, either an integer or a list of values with their @@ -127,11 +158,11 @@ data ArgType = ATInteger | ATIntegerList -- types. Only supports integers and integer lists currently. class ArgCount f where -- | Get the number of arguments to a function. - getArgs :: f -> Integer + getArgs :: Proxy f -> Integer getArgs = (+ (-1)) . fromIntegral . length . getTypes -- | Get the types of arguments to a function. - getTypes :: f -> [ArgType] + getTypes :: Proxy f -> [ArgType] instance ArgCount Integer where getTypes _ = [ATInteger] @@ -140,10 +171,10 @@ instance ArgCount [Integer] where getTypes _ = [ATIntegerList] instance ArgCount f => ArgCount (Integer -> f) where - getTypes f = ATInteger : getTypes (f 1) + getTypes _ = ATInteger : getTypes (Proxy :: Proxy f) instance ArgCount f => ArgCount ([Integer] -> f) where - getTypes f = ATIntegerList : getTypes (f [1]) + getTypes _ = ATIntegerList : getTypes (Proxy :: Proxy f) -- | Type class which represents applying a function f to some inputs when given -- the bounds for the function and some number of inputs. @@ -187,21 +218,21 @@ instance {-# OVERLAPPING #-} ApplyFunc [Integer] where -- argument value is an integer. If there are no arguments or the argument is -- of the wrong type, an exception is thrown. instance {-# OVERLAPPABLE #-} (ApplyFunc f) => ApplyFunc (Integer -> f) where - applyFunc f args _ [] = throwBot $ EvaluationException ("incorrect number of arguments to function. got " <> show dif <> ", expected " <> show args) [] + applyFunc _ args _ [] = throwBot $ EvaluationException ("incorrect number of arguments to function. got " <> show dif <> ", expected " <> show args) [] where - dif = args - getArgs f + dif = args - getArgs (Proxy :: Proxy f) applyFunc f args bs ((LIInteger x) : xs) = checkBounds x bs >>= \x' -> applyFunc (f x') args bs xs - applyFunc _ _ _ (_ : _) = throwBot $ EvaluationException "incorrect type given to function. expected an integer, got a list" [] + applyFunc _ _ _ _ = throwBot $ EvaluationException "incorrect type given to function. expected an integer, got a list" [] -- This is one of two recursive cases for applyFunc. This is the case where the -- argument value is a list of integers. If there are no arguments or the -- argument is of the wrong type, an exception is thrown. instance {-# OVERLAPPABLE #-} (ApplyFunc f) => ApplyFunc ([Integer] -> f) where - applyFunc f args _ [] = throwBot $ EvaluationException ("incorrect number of arguments to function. got " <> show dif <> ", expected " <> show args) [] + applyFunc _ args _ [] = throwBot $ EvaluationException ("incorrect number of arguments to function. got " <> show dif <> ", expected " <> show args) [] where - dif = args - getArgs f + dif = args - getArgs (Proxy :: Proxy f) applyFunc f args bs ((LIList x) : xs) = applyFunc (f x) args bs xs - applyFunc _ _ _ (_ : _) = throwBot $ EvaluationException "incorrect type given to function. expected a list, got an integer" [] + applyFunc _ _ _ _ = throwBot $ EvaluationException "incorrect type given to function. expected a list, got an integer" [] -- | Simple type family that gets the return type of whatever function or value -- is given diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs b/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs index 404f1ee0..e9462cc0 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LiberalTypeSynonyms #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | @@ -25,10 +26,10 @@ import Tablebot.Plugins.Roll.Dice.DiceFunctions integerFunctions, listFunctions, ) -import Tablebot.Utility.Parser (integer, parseCommaSeparated1, skipSpace) +import Tablebot.Utility.Parser import Tablebot.Utility.SmartParser (CanParse (..), ()) import Tablebot.Utility.Types (Parser) -import Text.Megaparsec (MonadParsec (try), choice, failure, optional, (), (<|>)) +import Text.Megaparsec (MonadParsec (try), choice, failure, optional, some, (), (<|>)) import Text.Megaparsec.Char (char, string) import Text.Megaparsec.Error (ErrorItem (Tokens)) @@ -36,15 +37,64 @@ import Text.Megaparsec.Error (ErrorItem (Tokens)) failure' :: T.Text -> Set T.Text -> Parser a failure' s ss = failure (Just $ Tokens $ NE.fromList $ T.unpack s) (S.map (Tokens . NE.fromList . T.unpack) ss) +variableName :: Parser T.Text +variableName = T.pack <$> some (choice $ char <$> '_' : ['a' .. 'z']) + +instance CanParse a => CanParse (Var a) where + pars = do + _ <- try (string "var") <* skipSpace + letCon <- try (char '!' $> VarLazy) <|> return Var + varName' <- variableName + _ <- skipSpace >> char '=' >> skipSpace + letCon varName' <$> pars + +instance CanParse Statement where + pars = ((StatementListValues <$> try pars) <|> (StatementExpr <$> pars)) <* skipSpace <* char ';' <* skipSpace + +{- +-- alternative method to the above. +-- from https://canary.discord.com/channels/280033776820813825/280036215477239809/938154455612919838 +-- - Morrow#1157 +newtype VarCon = VarCon (forall a. a -> Var a) + +parseLet :: Parser VarCon +parseLet = do + _ <- try (string "var") <* skipSpace + lazy <- try (char '!' $> True) <|> return False + varName' <- varName + _ <- skipSpace >> char '=' >> skipSpace + return $ VarCon (\a -> if lazy then VarLazy varName' a else Var varName' a) + +instance CanParse Statement where + pars = do + VarCon letP <- parseVar + val <- (Left <$> pars <|> Right <$> pars) <* skipSpace <* char ';' <* skipSpace + return $ either (VarList . letP) (VarExpr . letP) val +-} + +parseStatements :: Parser [Statement] +parseStatements = do + s <- optional $ try pars + case s of + Nothing -> return [] + Just s' -> (s' :) <$> parseStatements + +instance CanParse Program where + pars = parseStatements >>= \ss -> Program ss <$> pars + instance CanParse ListValues where pars = do functionParser listFunctions LVFunc - <|> ( do - nb <- try (pars <* char '#') - MultipleValues nb <$> pars - ) + <|> (LVVar . ("l_" <>) <$> try (string "l_" *> variableName)) + <|> ListValuesMisc <$> (pars >>= checkVar) + <|> (try (pars <* char '#') >>= \nb -> MultipleValues nb <$> pars) <|> LVBase <$> pars + where + checkVar (MiscVar l) + | T.isPrefixOf "l_" (varName l) = return (MiscVar l) + | otherwise = fail "list variables must be prepended with l_" + checkVar l = return l instance CanParse ListValuesBase where pars = do @@ -64,10 +114,23 @@ instance CanParse ListValuesBase where binOpParseHelp :: (CanParse a) => Char -> (a -> a) -> Parser a binOpParseHelp c con = try (skipSpace *> char c) *> skipSpace *> (con <$> pars) -instance CanParse Expr where +instance (CanParse b) => CanParse (If b) where pars = do - t <- pars - binOpParseHelp '+' (Add t) <|> binOpParseHelp '-' (Sub t) <|> (return . NoExpr) t + a <- string "if" *> skipSpace1 *> pars <* skipSpace1 + t <- string "then" *> skipSpace1 *> pars <* skipSpace1 + e <- string "else" *> skipSpace1 *> pars + return $ If a t e + +instance CanParse a => CanParse (MiscData a) where + pars = (MiscVar <$> pars) <|> (MiscIf <$> pars) + +instance CanParse Expr where + pars = + (ExprMisc <$> pars) + <|> ( do + t <- pars + binOpParseHelp '+' (Add t) <|> binOpParseHelp '-' (Sub t) <|> (return . NoExpr) t + ) instance CanParse Term where pars = do @@ -115,11 +178,12 @@ instance (CanParse a) => CanParse (Paren a) where instance CanParse Base where pars = ( do - nb <- try pars + nb <- try pars "could not parse numbase in base" (DiceBase <$> parseDice nb) <|> return (NBase nb) ) <|> DiceBase <$> parseDice (Value 1) + <|> (NumVar <$> try variableName) instance CanParse Die where pars = do @@ -200,3 +264,94 @@ parseArgValues :: [ArgType] -> Parser [ArgValue] parseArgValues [] = return [] parseArgValues [at] = (: []) <$> parseArgValue at parseArgValues (at : ats) = parseArgValue at >>= \av -> skipSpace *> (try (char ',') "expected " ++ show (length ats) ++ " more arguments") *> skipSpace *> ((av :) <$> parseArgValues ats) + +--- Pretty printing the AST + +instance ParseShow ArgValue where + parseShow (AVExpr e) = parseShow e + parseShow (AVListValues lv) = parseShow lv + +instance ParseShow ListValues where + parseShow (LVBase e) = parseShow e + parseShow (MultipleValues nb b) = parseShow nb <> "#" <> parseShow b + parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")" + parseShow (LVVar t) = t + parseShow (ListValuesMisc l) = parseShow l + +instance ParseShow ListValuesBase where + parseShow (LVBList es) = "{" <> T.intercalate ", " (parseShow <$> es) <> "}" + parseShow (LVBParen p) = parseShow p + +instance ParseShow a => ParseShow (MiscData a) where + parseShow (MiscVar l) = parseShow l + parseShow (MiscIf l) = parseShow l + +instance ParseShow Expr where + parseShow (Add t e) = parseShow t <> " + " <> parseShow e + parseShow (Sub t e) = parseShow t <> " - " <> parseShow e + parseShow (NoExpr t) = parseShow t + parseShow (ExprMisc e) = parseShow e + +instance ParseShow Term where + parseShow (Multi f t) = parseShow f <> " * " <> parseShow t + parseShow (Div f t) = parseShow f <> " / " <> parseShow t + parseShow (NoTerm f) = parseShow f + +instance ParseShow Func where + parseShow (Func s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")" + parseShow (NoFunc b) = parseShow b + +instance ParseShow Negation where + parseShow (Neg expo) = "-" <> parseShow expo + parseShow (NoNeg expo) = parseShow expo + +instance ParseShow Expo where + parseShow (NoExpo b) = parseShow b + parseShow (Expo b expo) = parseShow b <> " ^ " <> parseShow expo + +instance ParseShow NumBase where + parseShow (NBParen p) = parseShow p + parseShow (Value i) = T.pack $ show i + +instance (ParseShow a) => ParseShow (Paren a) where + parseShow (Paren a) = "(" <> parseShow a <> ")" + +instance ParseShow Base where + parseShow (NBase nb) = parseShow nb + parseShow (DiceBase dop) = parseShow dop + parseShow (NumVar t) = t + +instance ParseShow Die where + parseShow (Die b) = "d" <> parseShow b + parseShow (CustomDie lv) = "d" <> parseShow lv + -- parseShow (CustomDie is) = "d{" <> intercalate ", " (parseShow <$> is) <> "}" + parseShow (LazyDie d) = "d!" <> T.tail (parseShow d) + +instance ParseShow Dice where + parseShow (Dice b d dor) = parseShow b <> parseShow d <> helper' dor + where + fromOrdering ao = M.findWithDefault "??" ao $ snd advancedOrderingMapping + fromLHW (Where o i) = "w" <> fromOrdering o <> parseShow i + fromLHW (Low i) = "l" <> parseShow i + fromLHW (High i) = "h" <> parseShow i + helper' Nothing = "" + helper' (Just (DieOpRecur dopo' dor')) = helper dopo' <> helper' dor' + helper (DieOpOptionLazy doo) = "!" <> helper doo + helper (Reroll True o i) = "ro" <> fromOrdering o <> parseShow i + helper (Reroll False o i) = "rr" <> fromOrdering o <> parseShow i + helper (DieOpOptionKD Keep lhw) = "k" <> fromLHW lhw + helper (DieOpOptionKD Drop lhw) = "d" <> fromLHW lhw + +instance (ParseShow a) => ParseShow (Var a) where + parseShow (Var t a) = "var " <> t <> " = " <> parseShow a + parseShow (VarLazy t a) = "var !" <> t <> " = " <> parseShow a + +instance (ParseShow b) => ParseShow (If b) where + parseShow (If b t e) = "if " <> parseShow b <> " then " <> parseShow t <> " else " <> parseShow e + +instance ParseShow Statement where + parseShow (StatementExpr l) = parseShow l <> "; " + parseShow (StatementListValues l) = parseShow l <> "; " + +instance ParseShow Program where + parseShow (Program ss a) = foldr ((<>) . parseShow) (parseShow a) ss diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs index fba5dbbb..473fdd89 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs @@ -16,6 +16,7 @@ import Data.Bifunctor (Bifunctor (first)) import Data.Distribution hiding (Distribution, Experiment, fromList) import qualified Data.Distribution as D import Data.List +import qualified Data.Map as M import Tablebot.Plugins.Roll.Dice.DiceData import Tablebot.Plugins.Roll.Dice.DiceEval import Tablebot.Plugins.Roll.Dice.DiceFunctions @@ -45,7 +46,7 @@ getStats d = (modalOrder, expectation d, standardDeviation d) -- | Convenience wrapper which gets the range of the given values then applies -- the function to the resultant distributions. -combineRangesBinOp :: (MonadException m, Range a, Range b, PrettyShow a, PrettyShow b) => (Integer -> Integer -> Integer) -> a -> b -> m Experiment +combineRangesBinOp :: (MonadException m, Range a, Range b, ParseShow a, ParseShow b) => (Integer -> Integer -> Integer) -> a -> b -> m Experiment combineRangesBinOp f a b = do d <- range a d' <- range b @@ -75,18 +76,49 @@ rangeListValues lv = do -- has a variety of functions that operate on them. -- -- An `Data.Distribution.Experiment` is a monadic form of this. -class Range a where +class ParseShow a => Range a where -- | Try and get the `Experiment` of the given value, throwing a -- `MonadException` on failure. - range :: (MonadException m, PrettyShow a) => a -> m Experiment - range a = propagateException (prettyShow a) (range' a) + range :: (MonadException m, ParseShow a) => a -> m Experiment + range a = propagateException (parseShow a) (range' a) - range' :: (MonadException m, PrettyShow a) => a -> m Experiment + range' :: (MonadException m, ParseShow a) => a -> m Experiment + +instance (Range a) => Range (MiscData a) where + range' (MiscVar l) = range l + range' (MiscIf i) = rangeIfExpr range i + +instance (RangeList a) => RangeList (MiscData a) where + rangeList' (MiscVar l) = rangeList l + rangeList' (MiscIf i) = rangeIfExpr rangeList i + +rangeIfExpr :: (MonadException m, Ord b) => (a -> m (D.Experiment b)) -> If a -> m (D.Experiment b) +rangeIfExpr func (If b t f) = do + b' <- range b + let mp = toMap $ run b' + canBeFalse = M.member 0 mp + canBeTrue = not $ M.null $ M.filterWithKey (\k _ -> k /= 0) mp + emptyExp = from $ D.fromList @_ @Integer [] + t' <- if canBeTrue then func t else return emptyExp + f' <- if canBeFalse then func f else return emptyExp + return $ + do + b'' <- b' + if b'' /= 0 then t' else f' + +instance (Range a) => Range (Var a) where + range' (Var _ a) = range a + range' (VarLazy _ a) = range a + +instance (RangeList a) => RangeList (Var a) where + rangeList' (Var _ a) = rangeList a + rangeList' (VarLazy _ a) = rangeList a instance Range Expr where range' (NoExpr t) = range t range' (Add t e) = combineRangesBinOp (+) t e range' (Sub t e) = combineRangesBinOp (-) t e + range' (ExprMisc t) = range t instance Range Term where range' (NoTerm t) = range t @@ -120,6 +152,7 @@ instance Range NumBase where instance Range Base where range' (NBase nb) = range nb range' (DiceBase d) = range d + range' b@(NumVar _) = evaluationException "cannot find range of variable" [parseShow b] instance Range Die where range' (LazyDie d) = range d @@ -208,13 +241,13 @@ rangeDieOpExperimentKD kd lhw is = do -- -- Only used within `DiceStats` as I have no interest in producing statistics on -- lists -class RangeList a where +class ParseShow a => RangeList a where -- | Try and get the `DistributionList` of the given value, throwing a -- `MonadException` on failure. - rangeList :: (MonadException m, PrettyShow a) => a -> m ExperimentList - rangeList a = propagateException (prettyShow a) (rangeList' a) + rangeList :: (MonadException m, ParseShow a) => a -> m ExperimentList + rangeList a = propagateException (parseShow a) (rangeList' a) - rangeList' :: (MonadException m, PrettyShow a) => a -> m ExperimentList + rangeList' :: (MonadException m, ParseShow a) => a -> m ExperimentList instance RangeList ListValuesBase where rangeList' (LVBList es) = do @@ -232,6 +265,8 @@ instance RangeList ListValues where valNum <- nbd getDiceExperiment valNum (run bd) rangeList' (LVFunc fi avs) = rangeFunction fi avs + rangeList' (ListValuesMisc m) = rangeList m + rangeList' b@(LVVar _) = evaluationException "cannot find range of variable" [parseShow b] rangeArgValue :: MonadException m => ArgValue -> m (D.Experiment ListInteger) rangeArgValue (AVExpr e) = (LIInteger <$>) <$> range e diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index 7d49b0a7..60c8efbf 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -10,43 +10,51 @@ module Tablebot.Plugins.Roll.Plugin (rollPlugin) where import Control.Monad.Writer (MonadIO (liftIO), void) -import Data.Bifunctor (Bifunctor (first)) import Data.ByteString.Lazy (toStrict) +import Data.Default (Default (def)) import Data.Distribution (isValid) -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text, intercalate, pack, replicate, unpack) import qualified Data.Text as T import Discord (restCall) -import Discord.Internal.Rest.Channel (ChannelRequest (CreateMessageDetailed), MessageDetailedOpts (MessageDetailedOpts)) -import Discord.Types (Message (messageAuthor, messageChannel)) +import Discord.Interactions + ( Interaction (..), + ) +import Discord.Internal.Rest.Channel (ChannelRequest (..), MessageDetailedOpts (..)) +import Discord.Types (ActionRow (..), Button (..), Message (..), User (..), UserId, mkButton, mkEmoji) import System.Timeout (timeout) +import Tablebot.Internal.Handler.Command (parseValue) import Tablebot.Plugins.Roll.Dice import Tablebot.Plugins.Roll.Dice.DiceData import Tablebot.Plugins.Roll.Dice.DiceStats (getStats, rangeExpr) import Tablebot.Plugins.Roll.Dice.DiceStatsBase (distributionByteString) import Tablebot.Utility -import Tablebot.Utility.Discord (Format (Code), formatText, sendMessage, toMention) +import Tablebot.Utility.Discord (Format (Code), formatText, sendCustomMessage, sendMessage, toMention') import Tablebot.Utility.Exception (BotException (EvaluationException), throwBot) -import Tablebot.Utility.Parser (inlineCommandHelper, skipSpace) -import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), WithError (WErr), pars) +import Tablebot.Utility.Parser +import Tablebot.Utility.SmartParser import Text.Megaparsec import Text.RawString.QQ (r) -- | The basic execution function for rolling dice. Both the expression and message are -- optional. If the expression is not given, then the default roll is used. -rollDice' :: Maybe (Either ListValues Expr) -> Maybe (Quoted Text) -> Message -> DatabaseDiscord () -rollDice' e' t m = do - let e = fromMaybe (Right defaultRoll) e' - (vs, ss) <- case e of - (Left a) -> liftIO $ first Left <$> evalList a - (Right b) -> liftIO $ first Right <$> evalInteger b - let msg = makeMsg vs ss - if countFormatting msg < 199 - then sendMessage m msg - else sendMessage m (makeMsg (simplify vs) (prettyShow e <> " `[could not display rolls]`")) +-- The userid of the user that called this command is also given. +rollDice'' :: Maybe Program -> Maybe (Quoted Text) -> UserId -> DatabaseDiscord Text +rollDice'' e' t uid = do + let e = fromMaybe (Program [] (Right defaultRoll)) e' + maybemsss <- liftIO $ timeout 1000000 $ evalProgram e + case maybemsss of + Nothing -> throwBot (EvaluationException "Could not process expression in one second" []) + -- vs is either a list of integers and their textual representation, or + -- a single integer. ss is the message + Just (vs, ss) -> do + let msg = makeMsg vs ss + if countFormatting msg < 199 + then return msg + else return (makeMsg (simplify vs) (parseShow e <> " `[could not display rolls]`")) where dsc = maybe ": " (\(Qu t') -> " \"" <> t' <> "\": ") t - baseMsg = toMention (messageAuthor m) <> " rolled" <> dsc + baseMsg = toMention' uid <> " rolled" <> dsc makeLine (i, s) = pack (show i) <> Data.Text.replicate (max 0 (6 - length (show i))) " " <> " ⟵ " <> s makeMsg (Right v) s = baseMsg <> s <> ".\nOutput: " <> pack (show v) makeMsg (Left []) _ = baseMsg <> "No output." @@ -57,22 +65,57 @@ rollDice' e' t m = do simplify li = li countFormatting s = (`div` 4) $ T.foldr (\c cf -> cf + (2 * fromEnum (c == '`')) + fromEnum (c `elem` ['~', '_', '*'])) 0 s +-- | A version of rollDice'' that is nicer to parse and has a constructed message. +rollDice' :: Maybe Program -> Maybe (Quoted Text) -> SenderUserId -> DatabaseDiscord MessageDetails +rollDice' e t (SenderUserId uid) = do + msg <- rollDice'' e t uid + return + ( (messageDetailsBasic msg) + { messageDetailsComponents = + Just + [ ActionRowButtons + -- we take the first 100 characters of the button customid + -- because they're only allowed to be 100 characters long. + -- the button is disabled if it's meant to be more than 100 + -- characters so we don't have to worry about this. + [ (mkButton buttonName (T.take 100 buttonCustomId)) + { buttonEmoji = Just (mkEmoji "🎲"), + buttonDisabled = buttonDisabled + } + ] + ] + } + ) + where + appendIf t' Nothing = t' + appendIf t' (Just e') = t' <> " " <> parseShow e' + buttonCustomId = (("roll reroll " <> pack (show uid)) `appendIf` e) `appendIf` t + (buttonName, buttonDisabled) = if T.length buttonCustomId > 100 then ("Expr too long", True) else ("Reroll", False) + +rollSlashCommandFunction :: Labelled "expression" "what's being evaluated" (Maybe Text) -> Labelled "quote" "associated message" (Maybe (Quoted Text)) -> SenderUserId -> DatabaseDiscord MessageDetails +rollSlashCommandFunction (Labelled mt) (Labelled qt) suid = do + lve <- mapM (parseValue (pars <* eof)) mt + rollDice' lve qt suid + +rerollComponentRecv :: ComponentRecv +rerollComponentRecv = ComponentRecv "reroll" (processComponentInteraction' rollDiceParserI True) + -- | Manually creating parser for this command, since SmartCommand doesn't work fully for -- multiple Maybe values rollDiceParser :: Parser (Message -> DatabaseDiscord ()) rollDiceParser = choice (try <$> options) where -- Just the value is given to the command, no quote. - justEither :: WithError "Incorrect expression/list value. Please check the expression" (Either ListValues Expr) -> Message -> DatabaseDiscord () + justEither :: WithError "Incorrect expression/list value. Please check the expression" Program -> SenderUserId -> DatabaseDiscord MessageDetails justEither (WErr x) = rollDice' (Just x) Nothing -- Nothing is given to the command, a default case. - nothingAtAll :: WithError "Expected eof" () -> Message -> DatabaseDiscord () + nothingAtAll :: WithError "Expected eof" () -> SenderUserId -> DatabaseDiscord MessageDetails nothingAtAll (WErr _) = rollDice' Nothing Nothing -- Both the value and the quote are present. - bothVals :: WithError "Incorrect format. Please check the expression and quote" (Either ListValues Expr, Quoted Text) -> Message -> DatabaseDiscord () + bothVals :: WithError "Incorrect format. Please check the expression and quote" (Program, Quoted Text) -> SenderUserId -> DatabaseDiscord MessageDetails bothVals (WErr (x, y)) = rollDice' (Just x) (Just y) -- Just the quote is given to the command. - justText :: WithError "Incorrect quote. Please check the quote format" (Quoted Text) -> Message -> DatabaseDiscord () + justText :: WithError "Incorrect quote. Please check the quote format" (Quoted Text) -> SenderUserId -> DatabaseDiscord MessageDetails justText (WErr x) = rollDice' Nothing (Just x) options = [ parseComm justEither, @@ -81,6 +124,19 @@ rollDiceParser = choice (try <$> options) parseComm justText ] +-- | Creating a parser for the component interactions stuff. Needs to be +-- manually made since I think the maybe parser stuff doesn't work properly +-- still? +rollDiceParserI :: Parser (Interaction -> DatabaseDiscord MessageDetails) +rollDiceParserI = choice (try <$> options) + where + options = + [ onlyAllowRequestor (\lv -> rollDice' (Just lv) Nothing), + onlyAllowRequestor (rollDice' Nothing Nothing), + onlyAllowRequestor (\lv qt -> rollDice' (Just lv) (Just qt)), + onlyAllowRequestor (rollDice' Nothing . Just) + ] + -- | Basic command for rolling dice. rollDice :: Command rollDice = Command "roll" rollDiceParser [statsCommand] @@ -92,7 +148,9 @@ rollDice = Command "roll" rollDiceParser [statsCommand] -- | Rolling dice inline. rollDiceInline :: InlineCommand -rollDiceInline = inlineCommandHelper "[|" "|]" pars (\e m -> rollDice' (Just e) Nothing m) +rollDiceInline = inlineCommandHelper "[|" "|]" pars (\e m -> runFunc e m >>= sendCustomMessage m) + where + runFunc e m = rollDice' (Just e) Nothing (SenderUserId $ userId $ messageAuthor m) -- | Help page for rolling dice, with a link to the help page. rollHelp :: HelpPage @@ -114,13 +172,17 @@ Given an expression, evaluate the expression. Can roll inline using |] ++ "`[|to roll|]`." ++ [r| Can use `r` instead of `roll`. -This supports addition, subtraction, multiplication, integer division, exponentiation, parentheses, dice of arbitrary size, dice with custom sides, rerolling dice once on a condition, rerolling dice indefinitely on a condition, keeping or dropping the highest or lowest dice, keeping or dropping dice based on a condition, operating on lists (which have a maximum, configurable size of 50), and using functions like |] +This supports addition, subtraction, multiplication, integer division, exponentiation, parentheses, rolling dice of arbitrary size (up to |] + ++ show maximumRNG + ++ [r| RNG calls), dice with custom sides, rerolling dice once on a condition, rerolling dice indefinitely on a condition, keeping or dropping the highest or lowest dice, keeping or dropping dice based on a condition, operating on lists (which have a maximum size of |] + ++ show maximumListLength + ++ [r|), if statements, var statements, and using functions like |] ++ unpack (intercalate ", " integerFunctionsList) ++ [r| (which return integers), or functions like |] ++ unpack (intercalate ", " listFunctionsList) ++ [r| (which return lists). -To see a full list of uses, options and limitations, please go to . +To see a full list of uses, options and limitations, please go to . *Usage:* - `roll 1d20` -> rolls a twenty sided die and returns the outcome @@ -133,7 +195,7 @@ To see a full list of uses, options and limitations, please go to rpgSystems') where - doDiceRoll (nm, lv) = (nm, parseComm $ rollDice' (Just (Left lv)) (Just (Qu ("genchar for " <> nm)))) + doDiceRoll (nm, lv) = (nm, parseComm $ rollDice' (Just (Program [] (Left lv))) (Just (Qu ("genchar for " <> nm)))) rpgSystems' = doDiceRoll <$> rpgSystems toCommand (nm, ps) = Command nm ps [] @@ -168,7 +230,7 @@ statsCommand = Command "stats" statsCommandParser [] return $ statsCommand' (firstE : restEs) statsCommand' :: [Expr] -> Message -> DatabaseDiscord () statsCommand' es m = do - mrange' <- liftIO $ timeout (oneSecond * 5) $ mapM (\e -> rangeExpr e >>= \re -> re `seq` return (re, prettyShow e)) es + mrange' <- liftIO $ timeout (oneSecond * 5) $ mapM (\e -> rangeExpr e >>= \re -> re `seq` return (re, parseShow e)) es case mrange' of Nothing -> throwBot (EvaluationException "Timed out calculating statistics" []) (Just range') -> do @@ -181,7 +243,13 @@ statsCommand = Command "stats" statsCommandParser [] liftDiscord $ void $ restCall - ( CreateMessageDetailed (messageChannel m) (MessageDetailedOpts (msg range') False Nothing (Just (T.unwords (snd <$> range') <> ".png", toStrict image)) Nothing Nothing) + ( CreateMessageDetailed + (messageChannelId m) + ( def + { messageDetailedContent = msg range', + messageDetailedFile = Just (T.unwords (snd <$> range') <> ".png", toStrict image) + } + ) ) where msg [(d, t)] = @@ -221,7 +289,7 @@ statsHelp = "stats" [] "calculate and display statistics for expressions." - "**Roll Stats**\nCan be used to display statistics for expressions of dice.\n\n*Usage:* `roll stats 2d20kh1`, `roll stats 4d6rr=1dl1+5`, `roll stats 3d6dl1+6 4d6dl1`" + "**Roll Stats**\nCan be used to display statistics for expressions of dice.\nDoes not work with \"programs\" ie multiple statements one after the other, or with accessing variables.\n\n*Usage:* `roll stats 2d20kh1`, `roll stats 4d6rr=1dl1+5`, `roll stats 3d6dl1+6 4d6dl1`" [] None @@ -231,5 +299,7 @@ rollPlugin = (plug "roll") { commands = [rollDice, commandAlias "r" rollDice, genchar], helpPages = [rollHelp, gencharHelp], - inlineCommands = [rollDiceInline] + inlineCommands = [rollDiceInline], + onComponentRecvs = [rerollComponentRecv], + applicationCommands = catMaybes [makeApplicationCommandPair "roll" "roll some dice with a description" rollSlashCommandFunction] } diff --git a/src/Tablebot/Plugins/Say.hs b/src/Tablebot/Plugins/Say.hs index a9fa4863..7194866b 100644 --- a/src/Tablebot/Plugins/Say.hs +++ b/src/Tablebot/Plugins/Say.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- A command that outputs its input. -module Tablebot.Plugins.Say (sayPlugin) where +module Tablebot.Plugins.Say (says) where import Data.Text (pack) import Discord.Types (Message (messageAuthor), User (userId)) @@ -43,3 +43,6 @@ Repeat the input. -- | @sayPlugin@ assembles the command into a plugin. sayPlugin :: Plugin sayPlugin = (plug "say") {commands = [say], helpPages = [sayHelp]} + +says :: CompiledPlugin +says = compilePlugin sayPlugin diff --git a/src/Tablebot/Plugins/Shibe.hs b/src/Tablebot/Plugins/Shibe.hs index c0556fa3..055650aa 100644 --- a/src/Tablebot/Plugins/Shibe.hs +++ b/src/Tablebot/Plugins/Shibe.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- This is an example plugin which just responds with a shibe photo to a .shibe call -module Tablebot.Plugins.Shibe (shibePlugin) where +module Tablebot.Plugins.Shibe (shibe) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson (eitherDecode) @@ -15,27 +15,17 @@ import Data.Functor ((<&>)) import Data.Text (Text, pack) import Network.HTTP.Conduit (Response (responseBody), parseRequest) import Network.HTTP.Simple (httpLBS) +import Tablebot.Utility import Tablebot.Utility.Discord (Message, sendMessage) import Tablebot.Utility.SmartParser (parseComm) -import Tablebot.Utility.Types - ( Command, - DatabaseDiscord, - EnvCommand (Command), - EnvPlugin (..), - HelpPage (HelpPage), - Plugin, - RequiredPermission (None), - commandAlias, - plug, - ) -- | @ShibeAPI@ is the basic data type for the JSON object that the Shibe API returns type ShibeAPI = Text -- | @shibe@ is a command that takes no arguments (using 'noArguments') and -- replies with an image of a shibe. Uses https://shibe.online/ for shibe images. -shibe :: Command -shibe = +shibes :: Command +shibes = Command "shibe" (parseComm sendShibe) @@ -105,4 +95,7 @@ birbHelp = HelpPage "bird" [] "displays an image of a bird" "**Bird**\nGets a ra -- | @shibePlugin@ assembles these commands into a plugin containing shibe shibePlugin :: Plugin -shibePlugin = (plug "shibe") {commands = [birb, commandAlias "bird" birb, shibe], helpPages = [birbHelp, shibeHelp]} +shibePlugin = (plug "shibe") {commands = [birb, commandAlias "bird" birb, shibes], helpPages = [birbHelp, shibeHelp]} + +shibe :: CompiledPlugin +shibe = compilePlugin shibePlugin diff --git a/src/Tablebot/Plugins/Suggest.hs b/src/Tablebot/Plugins/Suggest.hs index bf6b033d..e0ab4387 100644 --- a/src/Tablebot/Plugins/Suggest.hs +++ b/src/Tablebot/Plugins/Suggest.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- A command that shows the link for a user to suggest a new game to buy. -module Tablebot.Plugins.Suggest (suggestPlugin) where +module Tablebot.Plugins.Suggest (suggests) where import Data.Text (pack) import Tablebot.Utility @@ -38,3 +38,6 @@ suggestHelp = HelpPage "suggest" [] "show links to suggest a new game for the so suggestPlugin :: Plugin suggestPlugin = (plug "suggest") {commands = [suggest], helpPages = [suggestHelp]} + +suggests :: CompiledPlugin +suggests = compilePlugin suggestPlugin diff --git a/src/Tablebot/Plugins/Welcome.hs b/src/Tablebot/Plugins/Welcome.hs index 10f8ba5c..df4b1ad6 100644 --- a/src/Tablebot/Plugins/Welcome.hs +++ b/src/Tablebot/Plugins/Welcome.hs @@ -7,7 +7,7 @@ -- Portability : POSIX -- -- Commands for generating welcome messages. -module Tablebot.Plugins.Welcome (welcomePlugin) where +module Tablebot.Plugins.Welcome (welcome) where import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ask) @@ -101,3 +101,6 @@ welcomeStartUp = StartUp $ liftIO readCategories -- | @welcomePlugin@ assembles these commands into a plugin. welcomePlugin :: EnvPlugin SS welcomePlugin = (envPlug "welcome" welcomeStartUp) {commands = [favourite], helpPages = [favouriteHelp]} + +welcome :: CompiledPlugin +welcome = compilePlugin welcomePlugin diff --git a/src/Tablebot/Utility.hs b/src/Tablebot/Utility.hs index 85d7fc18..46f8ff8b 100644 --- a/src/Tablebot/Utility.hs +++ b/src/Tablebot/Utility.hs @@ -12,8 +12,12 @@ module Tablebot.Utility ( module Types, module Utils, + compilePlugin, + CompiledPlugin, ) where +import Tablebot.Internal.Plugins (compilePlugin) +import Tablebot.Internal.Types (CompiledPlugin) import Tablebot.Utility.Types as Types hiding (Pl) import Tablebot.Utility.Utils as Utils diff --git a/src/Tablebot/Utility/Discord.hs b/src/Tablebot/Utility/Discord.hs index 6b08fc26..a5626082 100644 --- a/src/Tablebot/Utility/Discord.hs +++ b/src/Tablebot/Utility/Discord.hs @@ -10,13 +10,16 @@ -- without having to lift Discord operations constantly. module Tablebot.Utility.Discord ( sendMessage, + sendCustomMessage, sendChannelMessage, sendReplyMessage, sendCustomReplyMessage, sendEmbedMessage, + sendChannelEmbedMessage, reactToMessage, findGuild, findEmoji, + getChannel, getMessage, getMessageMember, getReplyMessage, @@ -37,44 +40,70 @@ module Tablebot.Utility.Discord formatInput, TimeFormat, extractFromSnowflake, + createApplicationCommand, + removeApplicationCommandsNotInList, + interactionResponseDefer, + interactionResponseDeferUpdateMessage, + interactionResponseMessage, + interactionResponseCustomMessage, + interactionResponseComponentsUpdateMessage, + interactionResponseAutocomplete, ) where +import Control.Monad.Cont (liftIO) import Control.Monad.Exception (MonadException (throw)) import Data.Char (isDigit) +import Data.Default (Default (def)) import Data.Foldable (msum) +import Data.List ((\\)) import Data.Map.Strict (keys) import Data.Maybe (listToMaybe) import Data.String (IsString (fromString)) import Data.Text (Text, pack, unpack) import Data.Time.Clock (nominalDiffTimeToSeconds) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Discord (RestCallErrorCode, readCache, restCall) -import Discord.Internal.Gateway.Cache +import Discord (Cache (cacheGuilds), DiscordHandler, RestCallErrorCode, readCache, restCall) +import Discord.Interactions import qualified Discord.Requests as R import Discord.Types import GHC.Word (Word64) -import Tablebot.Internal.Cache -import Tablebot.Internal.Embed -import Tablebot.Utility (EnvDatabaseDiscord, liftDiscord) +import System.Environment (lookupEnv) +import Tablebot.Internal.Cache (fillEmojiCache, lookupEmojiCache) +import Tablebot.Internal.Embed (Embeddable (..)) +import Tablebot.Utility (EnvDatabaseDiscord, MessageDetails, convertMessageFormatBasic, convertMessageFormatInteraction, liftDiscord, messageDetailsBasic) import Tablebot.Utility.Exception (BotException (..)) -- | @sendMessage@ sends the input message @t@ in the same channel as message --- @m@. This returns an @Either RestCallErrorCode Message@ to denote failure or --- return the 'Message' that was just sent. +-- @m@. sendMessage :: Message -> Text -> EnvDatabaseDiscord s () sendMessage m t = do - res <- liftDiscord . restCall $ R.CreateMessage (messageChannel m) t + res <- liftDiscord . restCall $ R.CreateMessage (messageChannelId m) t + case res of + Left _ -> throw $ MessageSendException "Failed to send message." + Right _ -> return () + +-- | @sendCustomMessage@ sends the input message @mdo@ in the same channel as +-- message @m@. +-- +-- As opposed to @sendMessage@, this function takes in a MessageDetails, to +-- allow full functionality. Unless you are dealing with components or some +-- other specific message data, you shouldn't use this function. +sendCustomMessage :: + Message -> + MessageDetails -> + EnvDatabaseDiscord s () +sendCustomMessage m t = do + res <- liftDiscord . restCall $ R.CreateMessageDetailed (messageChannelId m) (convertMessageFormatBasic t) case res of Left _ -> throw $ MessageSendException "Failed to send message." Right _ -> return () -- | @sendChannelMessage@ sends the input message @t@ into the provided channel --- @m@. This returns an @Either RestCallErrorCode Message@ to denote failure or --- return the 'Message' that was just sent. +-- @m@. sendChannelMessage :: ChannelId -> Text -> @@ -85,23 +114,22 @@ sendChannelMessage c t = do Left _ -> throw $ MessageSendException "Failed to send message." Right _ -> return () --- | @sendReplyMessage@ sends the input message @t@ as a reply to the triggering message --- @m@. This returns an @Either RestCallErrorCode Message@ to denote failure or --- return the 'Message' that was just sent. +-- | @sendReplyMessage@ sends the input message @t@ as a reply to the triggering +-- message @m@. sendReplyMessage :: Message -> Text -> EnvDatabaseDiscord s () sendReplyMessage m t = do let ref = MessageReference (Just (messageId m)) Nothing Nothing False - res <- liftDiscord . restCall $ R.CreateMessageDetailed (messageChannel m) (R.MessageDetailedOpts t False Nothing Nothing Nothing (Just ref)) + res <- liftDiscord . restCall $ R.CreateMessageDetailed (messageChannelId m) (R.MessageDetailedOpts t False Nothing Nothing Nothing (Just ref) Nothing Nothing) case res of Left _ -> throw $ MessageSendException "Failed to send message." Right _ -> return () --- | @sendCustomReplyMessage@ sends the input message @t@ as a reply to a provided message id --- @m@. This returns an @Either RestCallErrorCode Message@ to denote failure or --- return the 'Message' that was just sent. +-- | @sendCustomReplyMessage@ sends the input message @t@ as a reply to a +-- provided message id @m@. +-- -- @fail'@ indicates whether the message should still send if the provided message id is invalid sendCustomReplyMessage :: Message -> @@ -111,14 +139,14 @@ sendCustomReplyMessage :: EnvDatabaseDiscord s () sendCustomReplyMessage m mid fail' t = do let ref = MessageReference (Just mid) Nothing Nothing fail' - res <- liftDiscord . restCall $ R.CreateMessageDetailed (messageChannel m) (R.MessageDetailedOpts t False Nothing Nothing Nothing (Just ref)) + res <- liftDiscord . restCall $ R.CreateMessageDetailed (messageChannelId m) (R.MessageDetailedOpts t False Nothing Nothing Nothing (Just ref) Nothing Nothing) case res of Left _ -> throw $ MessageSendException "Failed to send message." Right _ -> return () -- | @sendEmbedMessage@ sends the input message @t@ in the same channel as message --- @m@ with an additional full Embed. This returns an @Either RestCallErrorCode Message@ to denote failure or --- return the 'Message' that was just sent. +-- @m@ with an additional full Embed. +-- -- This is *really* janky. The library exposes *no way* to create a coloured embed through its main api, -- so I'm having to manually reimplement the sending logic just to add this in. -- If you suffer from nightmares, don't look in 'Tablebot.Handler.Embed'. Nothing good lives there. @@ -129,8 +157,16 @@ sendEmbedMessage :: Text -> e -> EnvDatabaseDiscord s () -sendEmbedMessage m t e = do - res <- liftDiscord . restCall $ TablebotEmbedRequest (messageChannel m) t (asEmbed e) +sendEmbedMessage m = sendChannelEmbedMessage (messageChannelId m) + +sendChannelEmbedMessage :: + Embeddable e => + ChannelId -> + Text -> + e -> + EnvDatabaseDiscord s () +sendChannelEmbedMessage cid t e = do + res <- liftDiscord . restCall $ R.CreateMessageDetailed cid (def {R.messageDetailedContent = t, R.messageDetailedEmbeds = Just [asEmbed e]}) case res of Left _ -> throw $ MessageSendException "Failed to send message." Right _ -> return () @@ -159,13 +195,13 @@ reactToMessage :: EnvDatabaseDiscord s (Either RestCallErrorCode ()) reactToMessage m e = liftDiscord . restCall $ - R.CreateReaction (messageChannel m, messageId m) e + R.CreateReaction (messageChannelId m, messageId m) e -- | @getReplyMessage@ returns the message being replied to (if applicable) getReplyMessage :: Message -> EnvDatabaseDiscord s (Maybe Message) getReplyMessage m = do - let m' = referencedMessage m - let mRef = messageReference m + let m' = messageReferencedMessage m + mRef = messageReference m case m' of Just msg -> return $ Just msg Nothing -> case mRef of @@ -183,7 +219,7 @@ getReplyMessage m = do -- | @getPrecedingMessage@ returns the message immediately above the provided message getPrecedingMessage :: Message -> EnvDatabaseDiscord s (Maybe Message) getPrecedingMessage m = do - mlst <- liftDiscord . restCall $ R.GetChannelMessages (messageChannel m) (1, R.BeforeMessage (messageId m)) + mlst <- liftDiscord . restCall $ R.GetChannelMessages (messageChannelId m) (1, R.BeforeMessage (messageId m)) case mlst of Right mlst' -> return $ listToMaybe mlst' @@ -192,7 +228,7 @@ getPrecedingMessage m = do -- | @getMessageMember@ returns the message member object if it was sent from a Discord server, -- or @Nothing@ if it was sent from a DM (or the API fails) getMessageMember :: Message -> EnvDatabaseDiscord s (Maybe GuildMember) -getMessageMember m = gMM (messageGuild m) m +getMessageMember m = gMM (messageGuildId m) m where maybeRight :: Either a b -> Maybe b maybeRight (Left _) = Nothing @@ -204,10 +240,10 @@ getMessageMember m = gMM (messageGuild m) m return $ maybeRight a findGuild :: Message -> EnvDatabaseDiscord s (Maybe GuildId) -findGuild m = case messageGuild m of +findGuild m = case messageGuildId m of Just a -> pure $ Just a Nothing -> do - let chanId = messageChannel m + let chanId = messageChannelId m channel <- getChannel chanId case fmap channelGuild channel of Right a -> pure $ Just a @@ -231,10 +267,18 @@ getGuildEmoji ename gid = do -- | search through all known guilds for an emoji with that name findEmoji :: Text -> EnvDatabaseDiscord s (Maybe Emoji) -findEmoji ename = fmap msum (liftDiscord readCache >>= cacheToEmoji) +findEmoji ename = fmap msum (emojiServers >>= cacheToEmoji) where - cacheToEmoji :: Cache -> EnvDatabaseDiscord s [Maybe Emoji] - cacheToEmoji cache = mapM (getGuildEmoji ename) (keys $ cacheGuilds cache) + cacheToEmoji :: [GuildId] -> EnvDatabaseDiscord s [Maybe Emoji] + cacheToEmoji ids = mapM (getGuildEmoji ename) ids + emojiServers :: EnvDatabaseDiscord s [GuildId] + emojiServers = do + maybeServers <- liftIO $ lookupEnv "EMOJI_SERVERS" + case maybeServers of + Just x -> pure (read x) + Nothing -> do + cache <- liftDiscord readCache + pure $ keys $ cacheGuilds cache -- | Render an Emoji formatEmoji :: Emoji -> Text @@ -263,6 +307,7 @@ toMention' u = "<@!" <> pack (show u) <> ">" fromMention :: Text -> Maybe UserId fromMention = fromMentionStr . unpack +-- | Try to get the userid from a given string. fromMentionStr :: String -> Maybe UserId fromMentionStr user | length user < 4 || head user /= '<' || last user /= '>' || (head . tail) user /= '@' || (head stripToNum /= '!' && (not . isDigit) (head stripToNum)) = Nothing @@ -271,8 +316,10 @@ fromMentionStr user where stripToNum = (init . tail . tail) user +-- | Data types for different time formats. data TimeFormat = Default | ShortTime | LongTime | ShortDate | LongDate | ShortDateTime | LongDateTime | Relative deriving (Show, Enum, Eq) +-- | Turn some UTCTime into the given TimeFormat. toTimestamp' :: TimeFormat -> UTCTime -> Text toTimestamp' format t = " pack (show $ toUtcSeconds t) <> toSuffix format <> ">" where @@ -288,21 +335,32 @@ toTimestamp' format t = " pack (show $ toUtcSeconds t) <> toSuffix format toSuffix LongDateTime = ":F" toSuffix Relative = ":R" +-- | Turn some UTCTime into the default time format. toTimestamp :: UTCTime -> Text toTimestamp = toTimestamp' Default +-- | Turn some UTCTime into a relative time format toRelativeTime :: UTCTime -> Text toRelativeTime = toTimestamp' Relative +-- | Create a link to a message when given the server id, channel id, and +-- message id. getMessageLink :: GuildId -> ChannelId -> MessageId -> Text getMessageLink g c m = pack $ "https://discord.com/channels/" ++ show g ++ "/" ++ show c ++ "/" ++ show m +-- | The data types of different formatting options. +-- +-- Note that repeatedly applying certain formatting options (such as `Italics`, +-- `Code`, and a few others) will result in other formats. data Format = Bold | Underline | Strikethrough | Italics | Code | CodeBlock deriving (Show, Eq) +-- | Format some `a` (that can be turned into a string format) with the given +-- formatting option. formatInput :: (IsString a, Show b, Semigroup a) => Format -> b -> a formatInput f b = formatText f (fromString $ show b) +-- | Format the given string-like object with the given format. formatText :: (IsString a, Semigroup a) => Format -> a -> a formatText Bold s = "**" <> s <> "**" formatText Underline s = "__" <> s <> "__" @@ -311,5 +369,83 @@ formatText Italics s = "*" <> s <> "*" formatText Code s = "`" <> s <> "`" formatText CodeBlock s = "```" <> s <> "```" +-- | Get the `Word64` within a `Snowflake`. extractFromSnowflake :: Snowflake -> Word64 extractFromSnowflake (Snowflake w) = w + +-- | When given an application id, an optional server id, and a +-- CreateApplicationCommand object, create the application command. +createApplicationCommand :: ApplicationId -> Maybe GuildId -> CreateApplicationCommand -> DiscordHandler ApplicationCommand +createApplicationCommand aid gid cac = do + res <- createAppComm + case res of + Left e -> throw $ InteractionException $ "Failed to create application command :" ++ show e + Right a -> return a + where + createAppComm = case gid of + Nothing -> restCall $ R.CreateGlobalApplicationCommand aid cac + Just gid' -> restCall $ R.CreateGuildApplicationCommand aid gid' cac + +-- | Remove all application commands that are active (optionally in the given +-- server) that aren't in the given list. +removeApplicationCommandsNotInList :: ApplicationId -> Maybe GuildId -> [ApplicationCommandId] -> DiscordHandler () +removeApplicationCommandsNotInList aid gid aciToKeep = do + allACs' <- getAppComm + case allACs' of + Left _ -> throw $ InteractionException "Failed to get all application commands." + Right aacs -> + let allACs = applicationCommandId <$> aacs + in mapM_ deleteAppComm (allACs \\ aciToKeep) + where + (getAppComm, deleteAppComm) = case gid of + Nothing -> (restCall $ R.GetGlobalApplicationCommands aid, restCall . R.DeleteGlobalApplicationCommand aid) + Just gid' -> (restCall $ R.GetGuildApplicationCommands aid gid', restCall . R.DeleteGuildApplicationCommand aid gid') + +-- | Defer an interaction response, extending the window of time to respond to +-- 15 minutes (from 3 seconds). +interactionResponseDefer :: Interaction -> EnvDatabaseDiscord s () +interactionResponseDefer i = do + res <- liftDiscord $ restCall $ R.CreateInteractionResponse (interactionId i) (interactionToken i) InteractionResponseDeferChannelMessage + case res of + Left _ -> throw $ InteractionException "Failed to defer interaction." + Right _ -> return () + +-- | Defer an interaction response, extending the window of time to respond to +-- 15 minutes (from 3 seconds). +-- +-- Used when updating a component message. Does not show that the bot is +-- thinking about the interaction. +interactionResponseDeferUpdateMessage :: Interaction -> EnvDatabaseDiscord s () +interactionResponseDeferUpdateMessage i = do + res <- liftDiscord $ restCall $ R.CreateInteractionResponse (interactionId i) (interactionToken i) InteractionResponseDeferUpdateMessage + case res of + Left _ -> throw $ InteractionException "Failed to defer interaction." + Right _ -> return () + +-- | Respond to the given interaction with the given text. +interactionResponseMessage :: Interaction -> Text -> EnvDatabaseDiscord s () +interactionResponseMessage i t = interactionResponseCustomMessage i (messageDetailsBasic t) + +-- | Respond to the given interaction with a custom messages object. +interactionResponseCustomMessage :: Interaction -> MessageDetails -> EnvDatabaseDiscord s () +interactionResponseCustomMessage i t = do + res <- liftDiscord $ restCall $ R.CreateInteractionResponse (interactionId i) (interactionToken i) (InteractionResponseChannelMessage (convertMessageFormatInteraction t)) + case res of + Left _ -> throw $ InteractionException "Failed to respond to interaction." + Right _ -> return () + +-- | Respond to the given interaction by updating the component's message. +interactionResponseComponentsUpdateMessage :: Interaction -> MessageDetails -> EnvDatabaseDiscord s () +interactionResponseComponentsUpdateMessage i t = do + res <- liftDiscord $ restCall $ R.CreateInteractionResponse (interactionId i) (interactionToken i) (InteractionResponseUpdateMessage (convertMessageFormatInteraction t)) + case res of + Left _ -> throw $ InteractionException "Failed to respond to interaction with components update." + Right _ -> return () + +-- | Respond to the given interaction by sending a list of choices back. +interactionResponseAutocomplete :: Interaction -> InteractionResponseAutocomplete -> EnvDatabaseDiscord s () +interactionResponseAutocomplete i ac = do + res <- liftDiscord $ restCall $ R.CreateInteractionResponse (interactionId i) (interactionToken i) (InteractionResponseAutocompleteResult ac) + case res of + Left _ -> throw $ InteractionException "Failed to respond to interaction with autocomplete response." + Right _ -> return () diff --git a/src/Tablebot/Utility/Embed.hs b/src/Tablebot/Utility/Embed.hs index 7330ddf3..b940baf6 100644 --- a/src/Tablebot/Utility/Embed.hs +++ b/src/Tablebot/Utility/Embed.hs @@ -11,60 +11,59 @@ module Tablebot.Utility.Embed where import Data.Text (Text) import Discord.Internal.Types -import Tablebot.Internal.Embed (Embeddable, asEmbed, colourToInternal) -import Tablebot.Utility.Types (DiscordColour) +import Tablebot.Internal.Embed (Embeddable, asEmbed) -- | Some helper functions to allow progressively building up an embed -- If you need something more complex, you can still use the createEmbed flow provided by discord-haskell, -- its not bad (once you realise that it turns empty strings into Nothing for you...) but it can't do colours. -- To add a colour run createEmbed on it and then use one of these functions to manipulate it -simpleEmbed :: Text -> Embed -simpleEmbed t = createEmbed $ CreateEmbed "" "" Nothing "" "" Nothing t [] Nothing "" Nothing Nothing +simpleEmbed :: Text -> CreateEmbed +simpleEmbed t = CreateEmbed "" "" Nothing "" "" Nothing t [] Nothing "" Nothing Nothing Nothing -addTitle :: Embeddable e => Text -> e -> Embed +addTitle :: Embeddable e => Text -> e -> CreateEmbed addTitle t e = (asEmbed e) - { embedTitle = Just t + { createEmbedTitle = t } -addFooter :: Embeddable e => Text -> e -> Embed +addFooter :: Embeddable e => Text -> e -> CreateEmbed addFooter t e = (asEmbed e) - { embedFooter = Just $ EmbedFooter t Nothing Nothing + { createEmbedFooterText = t } -addTimestamp :: UTCTime -> Embed -> Embed +addTimestamp :: Embeddable e => UTCTime -> e -> CreateEmbed addTimestamp t e = - e - { embedTimestamp = Just t + (asEmbed e) + { createEmbedTimestamp = Just t } -addAuthor :: Text -> Embed -> Embed +addAuthor :: Embeddable e => Text -> e -> CreateEmbed addAuthor t e = (asEmbed e) - { embedAuthor = Just $ EmbedAuthor (Just t) Nothing Nothing Nothing + { createEmbedAuthorName = t } -addLink :: Text -> Embed -> Embed +addLink :: Embeddable e => Text -> e -> CreateEmbed addLink t e = - e - { embedUrl = Just t + (asEmbed e) + { createEmbedUrl = t } -addColour :: DiscordColour -> Embed -> Embed +addColour :: Embeddable e => DiscordColor -> e -> CreateEmbed addColour c e = (asEmbed e) - { embedColor = Just $ colourToInternal c + { createEmbedColor = Just c } -addImage :: Embeddable e => Text -> e -> Embed +addImage :: Embeddable e => Text -> e -> CreateEmbed addImage url e = (asEmbed e) - { embedImage = Just $ EmbedImage (Just url) Nothing Nothing Nothing + { createEmbedImage = Just $ CreateEmbedImageUrl url } -addThumbnail :: Embeddable e => Text -> e -> Embed +addThumbnail :: Embeddable e => Text -> e -> CreateEmbed addThumbnail url e = (asEmbed e) - { embedThumbnail = Just $ EmbedThumbnail (Just url) Nothing Nothing Nothing + { createEmbedThumbnail = Just $ CreateEmbedImageUrl url } diff --git a/src/Tablebot/Utility/Exception.hs b/src/Tablebot/Utility/Exception.hs index deb957b2..3e8231be 100644 --- a/src/Tablebot/Utility/Exception.hs +++ b/src/Tablebot/Utility/Exception.hs @@ -24,7 +24,6 @@ import Data.List (intercalate) import Data.Text (pack) import Discord.Internal.Types import Tablebot.Utility.Embed -import Tablebot.Utility.Types (DiscordColour (..)) -- | @BotException@ is the type for errors caught in TableBot. -- Declare new errors here, and define them at the bottom of the file. @@ -37,6 +36,8 @@ data BotException | EvaluationException String [String] | IOException String | NetrunnerException String + | InteractionException String + | PermissionException String deriving (Show, Eq) instance Exception BotException @@ -94,10 +95,10 @@ showUserError :: BotException -> String showUserError e = formatUserError (errorName e) (errorMsg e) -- | @embedError@ takes an error and makes it into an embed. -embedError :: BotException -> Embed +embedError :: BotException -> CreateEmbed embedError e = addTitle (pack $ errorEmoji ++ " **" ++ errorName e ++ "** " ++ errorEmoji) $ - addColour Red $ + addColour DiscordColorRed $ simpleEmbed (pack $ errorMsg e) -- | @errorInfo@ takes a BotException and converts it into an ErrorInfo struct. @@ -126,3 +127,5 @@ errorInfo (EvaluationException msg' locs) = ErrorInfo "EvaluationException" $ ms else connectVs (reverse locs) errorInfo (IOException msg') = ErrorInfo "IOException" msg' errorInfo (NetrunnerException msg') = ErrorInfo "NetrunnerException" msg' +errorInfo (InteractionException msg') = ErrorInfo "InteractionException" msg' +errorInfo (PermissionException msg') = ErrorInfo "PermissionException" msg' diff --git a/src/Tablebot/Utility/Help.hs b/src/Tablebot/Utility/Help.hs index 88a015ed..7cbca082 100644 --- a/src/Tablebot/Utility/Help.hs +++ b/src/Tablebot/Utility/Help.hs @@ -9,6 +9,7 @@ -- This module creates functions and data structures to help generate help text for commands module Tablebot.Utility.Help where +import Data.Default (Default (def)) import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T @@ -21,25 +22,19 @@ import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.Types hiding (helpPages) import Text.Megaparsec (choice, chunk, eof, try, (), (<|>)) -rootBody :: Text -rootBody = - "**Tabletop Bot**\n\ - \This friendly little bot provides several tools to help with\ - \ the running of the Warwick Tabletop Games and Role-Playing Society Discord server." - helpHelpPage :: HelpPage helpHelpPage = HelpPage "help" [] "show information about commands" "**Help**\nShows information about bot commands\n\n*Usage:* `help `" [] None -generateHelp :: CombinedPlugin -> CombinedPlugin -generateHelp p = +generateHelp :: Text -> CombinedPlugin -> CombinedPlugin +generateHelp rootText p = p - { combinedSetupAction = return (PA [CCommand "help" (handleHelp (helpHelpPage : combinedHelpPages p)) []] [] [] [] [] [] []) : combinedSetupAction p + { combinedSetupAction = return (def {compiledCommands = [CCommand "help" (handleHelp rootText (helpHelpPage : combinedHelpPages p)) []]}) : combinedSetupAction p } -handleHelp :: [HelpPage] -> Parser (Message -> CompiledDatabaseDiscord ()) -handleHelp hp = parseHelpPage root +handleHelp :: Text -> [HelpPage] -> Parser (Message -> CompiledDatabaseDiscord ()) +handleHelp rootText hp = parseHelpPage root where - root = HelpPage "" [] "" rootBody hp None + root = HelpPage "" [] "" rootText hp None parseHelpPage :: HelpPage -> Parser (Message -> CompiledDatabaseDiscord ()) parseHelpPage hp = do diff --git a/src/Tablebot/Utility/Parser.hs b/src/Tablebot/Utility/Parser.hs index 5bf874cf..318beef2 100644 --- a/src/Tablebot/Utility/Parser.hs +++ b/src/Tablebot/Utility/Parser.hs @@ -200,3 +200,17 @@ parseCommaSeparated1 p = do first <- p others <- many (try (skipSpace *> char ',' *> skipSpace) *> p) return (first : others) + +-- | Type class to display a value in a way that can be parsed. +-- +-- `Right a === parse (pars :: Parser a) "" (parseShow a)` +class ParseShow a where + -- | Represent the value + parseShow :: a -> Text + +instance (ParseShow a, ParseShow b) => ParseShow (Either a b) where + parseShow (Left a) = parseShow a + parseShow (Right b) = parseShow b + +instance ParseShow Text where + parseShow t = t diff --git a/src/Tablebot/Utility/Permission.hs b/src/Tablebot/Utility/Permission.hs index e6b56def..37507427 100644 --- a/src/Tablebot/Utility/Permission.hs +++ b/src/Tablebot/Utility/Permission.hs @@ -9,15 +9,14 @@ -- This contains a simple interface for plugin authors to require a specific level of privilege. module Tablebot.Utility.Permission where -import Discord.Internal.Rest (Message) import Tablebot.Internal.Permission -import Tablebot.Utility.Discord (sendMessage) +import Tablebot.Utility.Exception (BotException (PermissionException), throwBot) import Tablebot.Utility.Types -- | @requirePermission@ only runs the inputted effect if permissions are matched. Otherwise it returns an error. -requirePermission :: RequiredPermission -> Message -> EnvDatabaseDiscord s () -> EnvDatabaseDiscord s () +requirePermission :: Context m => RequiredPermission -> m -> EnvDatabaseDiscord s a -> EnvDatabaseDiscord s a requirePermission perm m a = do p <- getSenderPermission m if userHasPermission perm p then a - else sendMessage m "Sorry, you don't have permission to do that." + else throwBot $ PermissionException "Sorry, you don't have permission to do that." diff --git a/src/Tablebot/Utility/Search.hs b/src/Tablebot/Utility/Search.hs index 02bd0832..7c6f8640 100644 --- a/src/Tablebot/Utility/Search.hs +++ b/src/Tablebot/Utility/Search.hs @@ -11,8 +11,12 @@ module Tablebot.Utility.Search ( FuzzyCosts (..), closestMatch, closestMatchWithCosts, + closestMatches, + closestMatchesWithCosts, closestPair, closestPairWithCosts, + closestPairs, + closestPairsWithCosts, closestValue, closestValueWithCosts, shortestSuperString, @@ -21,7 +25,8 @@ module Tablebot.Utility.Search where import Data.Char (toLower) -import Data.List (minimumBy) +import Data.Default +import Data.List (minimumBy, sortBy) import Data.Text (Text, isInfixOf, length, take) import Text.EditDistance @@ -38,6 +43,9 @@ data FuzzyCosts = FuzzyCosts transposition :: Int } +instance Default FuzzyCosts where + def = defaultFuzzyCosts + -- | @convertCosts@ turns the custom FuzzyCosts into Text.EditDistance's -- EditCosts. convertCosts :: FuzzyCosts -> EditCosts @@ -72,6 +80,18 @@ closestMatchWithCosts editCosts strings query = minimumBy (compareOn score) stri score :: String -> Int score = levenshteinDistance (convertCosts editCosts) (map toLower query) +-- | @closestMatches@ takes a list of strings and a query and orders the strings +-- by which most closely matches the query (closest matches first). +closestMatches :: [String] -> String -> [String] +closestMatches = closestMatchesWithCosts defaultFuzzyCosts + +-- | @closestMatchesWithCosts@ is @closestMatches@ with customisable edit costs. +closestMatchesWithCosts :: FuzzyCosts -> [String] -> String -> [String] +closestMatchesWithCosts editCosts strings query = sortBy (compareOn score) strings + where + score :: String -> Int + score = levenshteinDistance (convertCosts editCosts) (map toLower query) + -- | @closestPair@ takes a set of pairs and a query and finds the pair whose key -- most closely matches the query. closestPair :: [(String, a)] -> String -> (String, a) @@ -84,6 +104,18 @@ closestPairWithCosts editCosts pairs query = minimumBy (compareOn $ score . fst) score :: String -> Int score = levenshteinDistance (convertCosts editCosts) (map toLower query) +-- | @closestPairs@ takes a list of strings and a query and orders the strings +-- by which most closely matches the query (closest matches first). +closestPairs :: [(String, a)] -> String -> [(String, a)] +closestPairs = closestPairsWithCosts defaultFuzzyCosts + +-- | @closestMatchesWithCosts@ is @closestMatches@ with customisable edit costs. +closestPairsWithCosts :: FuzzyCosts -> [(String, a)] -> String -> [(String, a)] +closestPairsWithCosts editCosts pairs query = sortBy (compareOn (score . fst)) pairs + where + score :: String -> Int + score = levenshteinDistance (convertCosts editCosts) (map toLower query) + -- | @closestValue@ is @closestPair@ but it only returns the value of the -- matched pair. closestValue :: [(String, a)] -> String -> a diff --git a/src/Tablebot/Utility/SmartParser.hs b/src/Tablebot/Utility/SmartParser.hs index bcaf6b5f..c69f9ac4 100644 --- a/src/Tablebot/Utility/SmartParser.hs +++ b/src/Tablebot/Utility/SmartParser.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -- | -- Module : Tablebot.Utility.SmartParser -- Description : Automatic parser generation from function types. @@ -12,167 +9,13 @@ -- Generates a parser based on the shape of the command function. -- For example, if you have a command that takes in an Int as argument, we -- build a parser that reads in that Int and then runs the command. -module Tablebot.Utility.SmartParser where - -import Data.Proxy -import Data.String (IsString (fromString)) -import Data.Text (Text, pack) -import Discord.Types (Message) -import GHC.TypeLits -import Tablebot.Utility.Parser -import Tablebot.Utility.Types (EnvDatabaseDiscord, Parser) -import Text.Megaparsec - --- | Custom infix operator to replace the error of a failing parser (regardless --- of parser position) with a user given error message. --- --- Has some effects on other error parsing. Use if you want the error you give --- to be the one that is reported (unless this is used at a higher level.) --- --- Overwrites/overpowers WithError errors. -() :: Parser a -> String -> Parser a -() p s = do - r <- observing p - case r of - Left _ -> fail s - Right a -> return a - --- | @PComm@ defines function types that we can automatically turn into parsers --- by composing a parser per input of the function provided. --- For example, @Int -> Maybe Text -> Message -> DatabaseDiscord s ()@ builds a --- parser that reads in an @Int@, then some optional @Text@, and then uses --- those to run the provided function with the arguments parsed and the message --- itself. -class PComm commandty s where - parseComm :: commandty -> Parser (Message -> EnvDatabaseDiscord s ()) - --- As a base case, remove the spacing and check for eof. -instance {-# OVERLAPPING #-} PComm (Message -> EnvDatabaseDiscord s ()) s where - parseComm comm = skipSpace >> eof >> return comm - --- Second base case is the single argument - no trailing space is wanted so we --- have to specify this case. -instance {-# OVERLAPPING #-} CanParse a => PComm (a -> Message -> EnvDatabaseDiscord s ()) s where - parseComm comm = do - this <- pars @a - parseComm (comm this) - --- Recursive case is to parse the domain of the function type, then the rest. -instance {-# OVERLAPPABLE #-} (CanParse a, PComm as s) => PComm (a -> as) s where - parseComm comm = do - this <- parsThenMoveToNext @a - parseComm (comm this) - --- | @CanParse@ defines types from which we can generate parsers. -class CanParse a where - pars :: Parser a - parsThenMoveToNext :: Parser a - parsThenMoveToNext = pars <* (eof <|> skipSpace1) - --- Note: since FromString and (Read, Integral) can overlap, we cannot specify --- this instance as FromString a => CanParse a. -instance CanParse Text where - pars = pack <$> word - --- This overlaps CanParse [a], since String = [Char]. -instance {-# OVERLAPPING #-} CanParse String where - pars = word - --- | @Quoted a@ defines an input of type @a@ that is contained within quotes. -newtype Quoted a = Qu a deriving (Show) - -instance IsString a => CanParse (Quoted a) where - pars = Qu . fromString <$> quoted - --- A parser for @Maybe a@ attempts to parse @a@, returning @Just x@ if --- correctly parsed, else @Nothing@. -instance CanParse a => CanParse (Maybe a) where - pars = optional $ try (pars @a) - - -- Note: we override @parsThenMoveToNext@: - -- there will be no spaces to parse if the argument isn't present. - parsThenMoveToNext = - pars >>= \case - Nothing -> return Nothing - Just val -> Just val <$ (eof <|> skipSpace1) - --- A parser for @[a]@ parses any number of @a@s. -instance {-# OVERLAPPABLE #-} CanParse a => CanParse [a] where - pars = many pars - --- A parser for @Either a b@ attempts to parse @a@, and if that fails then --- attempts to parse @b@. -instance (CanParse a, CanParse b) => CanParse (Either a b) where - pars = (Left <$> try (pars @a)) <|> (Right <$> pars @b) - --- TODO: automate creation of tuple instances using TemplateHaskell -instance (CanParse a, CanParse b) => CanParse (a, b) where - pars = do - x <- parsThenMoveToNext @a - y <- pars @b - return (x, y) - -instance (CanParse a, CanParse b, CanParse c) => CanParse (a, b, c) where - pars = do - x <- parsThenMoveToNext @a - y <- parsThenMoveToNext @b - z <- pars @c - return (x, y, z) - -instance (CanParse a, CanParse b, CanParse c, CanParse d) => CanParse (a, b, c, d) where - pars = do - x <- parsThenMoveToNext @a - y <- parsThenMoveToNext @b - z <- parsThenMoveToNext @c - w <- pars @d - return (x, y, z, w) - -instance (CanParse a, CanParse b, CanParse c, CanParse d, CanParse e) => CanParse (a, b, c, d, e) where - pars = do - x <- parsThenMoveToNext @a - y <- parsThenMoveToNext @b - z <- parsThenMoveToNext @c - w <- parsThenMoveToNext @d - v <- pars @e - return (x, y, z, w, v) - --- | @Exactly s@ defines an input exactly matching @s@ and nothing else. -data Exactly (s :: Symbol) = Ex - -instance KnownSymbol s => CanParse (Exactly s) where - pars = chunk (pack $ symbolVal (Proxy :: Proxy s)) >> return Ex - --- | @WithError err x@ parses an @x@, reporting @err@ if the parsing of @x@ --- fails. -newtype WithError (err :: Symbol) x = WErr x - -instance (KnownSymbol err, CanParse x) => CanParse (WithError err x) where - pars = (WErr <$> try (pars @x)) symbolVal (Proxy :: Proxy err) - --- | Parsing implementation for all integral types --- Overlappable due to the really flexible head state -instance {-# OVERLAPPABLE #-} (Integral a, Read a) => CanParse a where - pars = integer - -instance CanParse Double where - pars = double - -instance CanParse () where - pars = eof - --- | @RestOfInput a@ parses the rest of the input, giving a value of type @a@. -newtype RestOfInput a = ROI a - -instance IsString a => CanParse (RestOfInput a) where - pars = ROI . fromString <$> untilEnd - --- | @RestOfInput a@ parses the rest of the input, giving a value of type @a@. -newtype RestOfInput1 a = ROI1 a - -instance IsString a => CanParse (RestOfInput1 a) where - pars = ROI1 . fromString <$> untilEnd1 - --- | @noArguments@ is a type-specific alias for @parseComm@ for commands that --- have no arguments (thus making it extremely clear). -noArguments :: (Message -> EnvDatabaseDiscord d ()) -> Parser (Message -> EnvDatabaseDiscord d ()) -noArguments = parseComm +module Tablebot.Utility.SmartParser + ( module Tablebot.Utility.SmartParser.SmartParser, + module Tablebot.Utility.SmartParser.Interactions, + module Tablebot.Utility.SmartParser.Types, + ) +where + +import Tablebot.Utility.SmartParser.Interactions +import Tablebot.Utility.SmartParser.SmartParser +import Tablebot.Utility.SmartParser.Types diff --git a/src/Tablebot/Utility/SmartParser/Interactions.hs b/src/Tablebot/Utility/SmartParser/Interactions.hs new file mode 100644 index 00000000..72ea2b08 --- /dev/null +++ b/src/Tablebot/Utility/SmartParser/Interactions.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Tablebot.Utility.Interactions +-- Description : Automatic parser generation from function types. +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Generates a parser based on the shape of the command function. +-- For example, if you have a command that takes in an Int as argument, we +-- build a parser that reads in that Int and then runs the command. +module Tablebot.Utility.SmartParser.Interactions where + +import Control.Monad.Exception (MonadException (catch)) +import Data.Default (Default (def)) +import Data.Proxy (Proxy (..)) +import Data.Scientific +import Data.Text (Text, pack) +import Discord.Interactions +import Discord.Types +import GHC.OldList (find) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Tablebot.Internal.Handler.Command (parseValue) +import Tablebot.Utility.Discord (interactionResponseComponentsUpdateMessage, interactionResponseCustomMessage) +import Tablebot.Utility.Exception (BotException (InteractionException, ParserException), catchBot, embedError, throwBot) +import Tablebot.Utility.Parser +import Tablebot.Utility.SmartParser.SmartParser (PComm (..)) +import Tablebot.Utility.SmartParser.Types +import Tablebot.Utility.Types +import Text.Megaparsec (MonadParsec (eof)) + +-- | Creates both the slash command creation data structure and the parser for +-- the command, and creates the EnvApplicationCommandRecv for the command by +-- combining them. +-- +-- Takes the name and description for a slash command, and its function. +makeApplicationCommandPair :: forall t s. (MakeAppComm t, ProcessAppComm t s) => Text -> Text -> t -> Maybe (EnvApplicationCommandRecv s) +makeApplicationCommandPair name desc f = do + cac <- makeSlashCommand name desc (Proxy :: Proxy t) + return $ ApplicationCommandRecv cac (processAppComm f) + +-- | Make the creation data structure for a slash command when given a proxy for +-- a function's type. +makeSlashCommand :: (MakeAppComm t) => Text -> Text -> Proxy t -> Maybe CreateApplicationCommand +makeSlashCommand name desc p = + createChatInput name desc >>= \cac -> + return $ + cac + { createOptions = Just $ OptionsValues $ makeAppComm p + } + +-- | Create a series of command option values from the given types. +-- +-- This is making the arguments for a text input/slash command from +-- a proxy of the given function. +class MakeAppComm commandty where + makeAppComm :: Proxy commandty -> [OptionValue] + +-- As a base case, no more arguments +instance {-# OVERLAPPING #-} MakeAppComm (EnvDatabaseDiscord s MessageDetails) where + makeAppComm _ = [] + +-- If there is a way to get an argument from a `ty`, then get that arg and continue recursion. +instance {-# OVERLAPPABLE #-} (MakeAppComm mac, MakeAppCommArg ty) => MakeAppComm (ty -> mac) where + makeAppComm _ = makeAppCommArg (Proxy :: Proxy ty) : makeAppComm (Proxy :: Proxy mac) + +-- we don't get the sender user id from the command itself, so ignore it +instance {-# OVERLAPPABLE #-} (MakeAppComm mac) => MakeAppComm (SenderUserId -> mac) where + makeAppComm _ = makeAppComm (Proxy :: Proxy mac) + +-- | From a single value, make an argument for a slash command command. +class MakeAppCommArg commandty where + makeAppCommArg :: Proxy commandty -> OptionValue + +-- | Create a labelled text argument. By default it is required and does not +-- have autocompeletion. +instance (KnownSymbol name, KnownSymbol desc) => MakeAppCommArg (Labelled name desc Text) where + makeAppCommArg l = OptionValueString n d True (Left False) + where + (n, d) = getLabelValues l + +-- | Create a labelled integer argument. By default it is required and does not +-- have autocompeletion, and does not have bounds. +instance (KnownSymbol name, KnownSymbol desc) => MakeAppCommArg (Labelled name desc Integer) where + makeAppCommArg l = OptionValueInteger n d True (Left False) Nothing Nothing + where + (n, d) = getLabelValues l + +-- | Create a labelled scientific argument. By default it is required and does not +-- have autocompeletion, and does not have bounds. +instance (KnownSymbol name, KnownSymbol desc) => MakeAppCommArg (Labelled name desc Scientific) where + makeAppCommArg l = OptionValueNumber n d True (Left False) Nothing Nothing + where + (n, d) = getLabelValues l + +-- | Create a labelled argument that is optional. +instance (KnownSymbol name, KnownSymbol desc, MakeAppCommArg (Labelled name desc t)) => MakeAppCommArg (Labelled name desc (Maybe t)) where + makeAppCommArg _ = + (makeAppCommArg (Proxy :: Proxy (Labelled name desc t))) + { optionValueRequired = False + } + +-- | When quoted text is required, just fake it and get a sub layer. +instance (KnownSymbol name, KnownSymbol desc, MakeAppCommArg (Labelled name desc t)) => MakeAppCommArg (Labelled name desc (Quoted t)) where + makeAppCommArg _ = makeAppCommArg (Proxy :: Proxy (Labelled name desc t)) + +-- As a base case, send the message produced + +-- | Process an application command when given a function/value. +-- +-- `s` is the context of the environment. +class ProcessAppComm commandty s where + processAppComm :: commandty -> Interaction -> EnvDatabaseDiscord s () + +-- When left with just a MessageDetails, just send the message as an +-- interaction response. +instance {-# OVERLAPPING #-} ProcessAppComm (EnvDatabaseDiscord s MessageDetails) s where + processAppComm comm i = comm >>= interactionResponseCustomMessage i + +-- If there is already an interaction in this function call, apply it and +-- recurse. +instance {-# OVERLAPPABLE #-} (ProcessAppComm pac s) => ProcessAppComm (Interaction -> pac) s where + processAppComm comm i = processAppComm (comm i) i + +-- This is the main recursion case. +-- +-- If the argument is a ProcessAppCommArg, then parse it and recurse. +instance {-# OVERLAPPABLE #-} (ProcessAppCommArg ty s, ProcessAppComm pac s) => ProcessAppComm (ty -> pac) s where + processAppComm comm i@InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {optionsData = opts}} = do + t <- processAppCommArg (getVs opts) + processAppComm (comm t) i + where + getVs (Just (OptionsDataValues vs)) = vs + getVs _ = [] + processAppComm _ _ = throwBot $ InteractionException "could not process args to application command" + +-- one specific implementation case when we want to parse out a user id. +instance {-# OVERLAPPABLE #-} (ProcessAppComm pac s) => ProcessAppComm (SenderUserId -> pac) s where + processAppComm comm i@InteractionApplicationCommand {interactionUser = MemberOrUser u} = + case getUser of + Nothing -> throwBot $ InteractionException "could not process args to application command" + Just uid -> processAppComm (comm (SenderUserId uid)) i + where + getUser = userId <$> either memberUser Just u + processAppComm _ _ = throwBot $ InteractionException "could not process args to application command" + +-- | Process an argument for an application command. +-- +-- Given a type `t`, parse a value of that type from the given list of option +-- values. +class ProcessAppCommArg t s where + processAppCommArg :: [OptionDataValue] -> EnvDatabaseDiscord s t + +-- | Given a string, find the first option value with that name in the list, +-- returning Nothing if none is found. +getValue :: String -> [OptionDataValue] -> Maybe OptionDataValue +getValue t = find ((== pack t) . optionDataValueName) + +-- | Tries to extract an integer from a given option value. +integerFromOptionValue :: OptionDataValue -> Maybe Integer +integerFromOptionValue OptionDataValueInteger {optionDataValueInteger = Right i} = Just i +integerFromOptionValue _ = Nothing + +-- | Tries to extract a scientific number from a given option value. +scientificFromOptionValue :: OptionDataValue -> Maybe Scientific +scientificFromOptionValue OptionDataValueNumber {optionDataValueNumber = Right i} = Just i +scientificFromOptionValue _ = Nothing + +-- | Tries to extract a string from a given option value. +stringFromOptionValue :: OptionDataValue -> Maybe Text +stringFromOptionValue OptionDataValueString {optionDataValueString = Right i} = Just i +stringFromOptionValue _ = Nothing + +-- there are a number of missing slash command argument types missing here, which I've not added yet. +-- we can add ids of various sorts + +-- extract a string of the given type from the arguments +instance (KnownSymbol name) => ProcessAppCommArg (Labelled name desc Text) s where + processAppCommArg is = case getValue (symbolVal (Proxy :: Proxy name)) is of + Just (OptionDataValueString _ (Right t)) -> return $ labelValue t + _ -> throwBot $ InteractionException "could not find required parameter" + +-- extract an integer of the given type from the arguments +instance (KnownSymbol name) => ProcessAppCommArg (Labelled name desc Integer) s where + processAppCommArg is = case getValue (symbolVal (Proxy :: Proxy name)) is of + Just (OptionDataValueInteger _ (Right i)) -> return $ labelValue i + _ -> throwBot $ InteractionException "could not find required parameter" + +-- extract a scientific number of the given type from the arguments +instance (KnownSymbol name) => ProcessAppCommArg (Labelled name desc Scientific) s where + processAppCommArg is = case getValue (symbolVal (Proxy :: Proxy name)) is of + Just (OptionDataValueNumber _ (Right i)) -> return $ labelValue i + _ -> throwBot $ InteractionException "could not find required parameter" + +-- extract a quote of the given type from the arguments +instance (KnownSymbol name, KnownSymbol desc, ProcessAppCommArg (Labelled name desc t) s) => ProcessAppCommArg (Labelled name desc (Quoted t)) s where + processAppCommArg is = processAppCommArg @(Labelled name desc t) is >>= \(Labelled a) -> return (labelValue (Qu a)) + +-- extract an optional data type from the arguments +instance (KnownSymbol name, ProcessAppCommArg (Labelled name desc t) s) => ProcessAppCommArg (Labelled name desc (Maybe t)) s where + processAppCommArg is = do + let result = processAppCommArg is :: EnvDatabaseDiscord s (Labelled name desc t) + ( do + (Labelled l) <- result + return (labelValue (Just l)) + ) + `catchBot` const (return $ labelValue Nothing) + +-- | Given a function that can be processed to create a parser, create an action +-- for it using the helper. Uses `parseComm` to generate the required parser. +-- +-- Components use a unique string as their identifier. We can use this to +-- run the normal command parser on, hence the use of PComm. +-- +-- If the boolean is False, a reply is sent to the interaction message. If the +-- boolean is True, the original message is updated. +-- +-- For more information, check the helper `processComponentInteraction'`. +processComponentInteraction :: (PComm f s Interaction MessageDetails) => f -> Bool -> Interaction -> EnvDatabaseDiscord s () +processComponentInteraction f = processComponentInteraction' (parseComm f) + +-- | Given a parser that, when run, returns a function taking an interaction +-- and returns a database action on some MessageDetails, run the action. +-- +-- If the boolean is true, the message the component is from is updated. Else, +-- a message is sent as the interaction response. +-- +-- The format of the Text being given should be of space separated values, +-- similar to the command structure. +processComponentInteraction' :: Parser (Interaction -> EnvDatabaseDiscord s MessageDetails) -> Bool -> Interaction -> EnvDatabaseDiscord s () +processComponentInteraction' compParser updateOriginal i@InteractionComponent {componentData = idc} = errorCatch $ do + let componentSend + | updateOriginal = interactionResponseComponentsUpdateMessage i + | otherwise = interactionResponseCustomMessage i + action <- parseValue (skipSpace *> compParser) (componentDataCustomId idc) >>= ($ i) + componentSend action + where + catchParserException e@(ParserException _ _) = interactionResponseCustomMessage i $ (messageDetailsBasic "something (likely) went wrong when processing a component interaction") {messageDetailsEmbeds = Just [embedError (e :: BotException)]} + catchParserException e = interactionResponseCustomMessage i $ (messageDetailsBasic "") {messageDetailsEmbeds = Just [embedError (e :: BotException)]} + errorCatch = (`catch` catchParserException) +processComponentInteraction' _ _ _ = throwBot $ InteractionException "could not process component interaction" + +-- | Function to only allow use of an interaction if the requestor matches +-- a Snowflake at the beginning of the input. This uses a helper, and by default +-- sends an ephermeral message with the text "You don't have permission to use +-- this component." +-- +-- Helper is `onlyAllowRequestor'`. +onlyAllowRequestor :: forall f. (PComm f () Interaction MessageDetails) => f -> Parser (Interaction -> DatabaseDiscord MessageDetails) +onlyAllowRequestor = + onlyAllowRequestor' + ( (messageDetailsBasic "You don't have permission to use this component.") {messageDetailsFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]} + ) + +-- | Take a message to send when a user that is not the one that created a +-- component, and then parse out a user id, and then get the interaction +-- requestor's userid, check if they match, and if they don't then send a +-- message. Regardless, parse out the given function. If it _does_ match, run +-- the parsed function. +-- +-- Adds eof to the end to ensure all the data is parsed. +onlyAllowRequestor' :: forall f. (PComm f () Interaction MessageDetails) => MessageDetails -> f -> Parser (Interaction -> DatabaseDiscord MessageDetails) +onlyAllowRequestor' msg f = do + pre <- parseComm prefunc + f' <- parseComm @f @() @Interaction @MessageDetails f + parseComm + ( \i -> do + isEqual <- pre i + case isEqual of + Nothing -> f' i + Just d -> return d + ) + <* eof + where + prefunc :: UserId -> SenderUserId -> Interaction -> DatabaseDiscord (Maybe MessageDetails) + prefunc uid (SenderUserId u) i = + if uid == u + then return Nothing + else + interactionResponseCustomMessage + i + msg + >> return (Just def) diff --git a/src/Tablebot/Utility/SmartParser/SmartParser.hs b/src/Tablebot/Utility/SmartParser/SmartParser.hs new file mode 100644 index 00000000..6a6ad34f --- /dev/null +++ b/src/Tablebot/Utility/SmartParser/SmartParser.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Tablebot.Utility.SmartParser.SmartParser +-- Description : Automatic parser generation from function types. +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- Generates a parser based on the shape of the command function. +-- For example, if you have a command that takes in an Int as argument, we +-- build a parser that reads in that Int and then runs the command. +module Tablebot.Utility.SmartParser.SmartParser where + +import Data.Proxy (Proxy (..)) +import Data.Scientific () +import Data.String (IsString (fromString)) +import Data.Text (Text, pack) +import Discord.Interactions () +import Discord.Types (Message, Snowflake (Snowflake)) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Tablebot.Utility.Discord (sendCustomMessage) +import Tablebot.Utility.Parser +import Tablebot.Utility.SmartParser.Types +import Tablebot.Utility.Types (Context (..), EnvDatabaseDiscord, MessageDetails, Parser) +import Text.Megaparsec (MonadParsec (eof, try), chunk, many, optional, (), (<|>)) + +-- | @PComm@ defines function types that we can automatically turn into parsers +-- by composing a parser per input of the function provided. +-- For example, @Int -> Maybe Text -> Message -> DatabaseDiscord s ()@ builds a +-- parser that reads in an @Int@, then some optional @Text@, and then uses +-- those to run the provided function with the arguments parsed and the message +-- itself. +-- +-- The arguments to this class are the type of the function, the type of the +-- environment, the type of the context (either Message or Interaction), and the +-- type of the result of the function (which is either () or MessageDetails +-- usually). +class PComm commandty s context returns where + parseComm :: (Context context) => commandty -> Parser (context -> EnvDatabaseDiscord s returns) + +-- TODO: verify that all the parsers for PComm actually work + +-- If there is the general case where we have just what we want to parse, then +-- return it +-- (1) +instance {-# OVERLAPPING #-} PComm (t -> EnvDatabaseDiscord s r) s t r where + parseComm comm = skipSpace >> return comm + +-- If we have the specific case where we are returning `()`, parse eof as well. +-- This should cover the base case for the rest of the program that doesn't use +-- more complex stuff. +-- (2) +instance {-# OVERLAPPING #-} PComm (t -> EnvDatabaseDiscord s ()) s t () where + parseComm comm = skipSpace >> eof >> return comm + +-- If an action takes a message and returns a message details and we want it to +-- return unit, assume that it wants to be sent, and send it. eof this as well +-- (3) +instance {-# OVERLAPPING #-} PComm (Message -> EnvDatabaseDiscord s MessageDetails) s Message () where + parseComm comm = skipSpace >> eof >> return (\m -> comm m >>= sendCustomMessage m) + +-- When there is no context to the function (eg no Message or Interaction), +-- just run the action. don't parse eof cause we may wanna return. +-- similar to (1) +-- (4) +instance PComm (EnvDatabaseDiscord s r) s t r where + parseComm comm = skipSpace >> return (const comm) + +-- When there is no context to the function (eg no Message or Interaction), +-- just run the action. effectively the function hasn't interacted with the `t`. +-- parse eof because we have unit here. similar to (2) +-- (5) +instance {-# OVERLAPPING #-} PComm (EnvDatabaseDiscord s ()) s t () where + parseComm comm = skipSpace >> eof >> return (const comm) + +-- if we're in a message context and have a message details but want to return +-- unit, assume that we want to send it, and send it. similar to (3) +-- (6) +instance {-# OVERLAPPING #-} PComm (EnvDatabaseDiscord s MessageDetails) s Message () where + parseComm comm = skipSpace >> eof >> return (\m -> comm >>= sendCustomMessage m) + +-- Recursive case is to parse the domain of the function type, then the rest. +-- (7) +instance {-# OVERLAPPABLE #-} (CanParse a, PComm as s t r) => PComm (a -> as) s t r where + parseComm comm = do + this <- parsThenMoveToNext @a + parseComm (comm this) + +-- if we have two contexts for some reason, collapse them if the resultant can +-- be parsed +-- (8) +instance {-# OVERLAPPABLE #-} (PComm (t -> as) s t r) => PComm (t -> t -> as) s t r where + parseComm comm = parseComm (\m -> comm m m) + +-- if we have a context and then some parseable value, effectively juggle the +-- context so that parsing continues (and the context is passed on) +-- (9) +instance {-# OVERLAPPABLE #-} (Context t, CanParse a, PComm (t -> as) s t r) => PComm (t -> a -> as) s t r where + parseComm comm = do + this <- parsThenMoveToNext @a + parseComm (`comm` this) + +-- special value case - if we get SenderUserId, we need to get the value from +-- the context. so, get the value from the context, and then continue parsing. +-- (10) +instance {-# OVERLAPPABLE #-} (PComm (t -> as) s t r) => PComm (SenderUserId -> as) s t r where + parseComm comm = parseComm $ \(m :: t) -> comm (SenderUserId $ contextUserId m) + +-- | @CanParse@ defines types from which we can generate parsers. +class CanParse a where + pars :: Parser a + parsThenMoveToNext :: Parser a + parsThenMoveToNext = pars <* (eof <|> skipSpace1) + +-- Note: since FromString and (Read, Integral) can overlap, we cannot specify +-- this instance as FromString a => CanParse a. +instance CanParse Text where + pars = pack <$> word + +-- This overlaps CanParse [a], since String = [Char]. +instance {-# OVERLAPPING #-} CanParse String where + pars = word + +instance IsString a => CanParse (Quoted a) where + pars = Qu . fromString <$> quoted + +instance (ParseShow a) => ParseShow (Quoted a) where + parseShow (Qu a) = "\"" <> parseShow a <> "\"" + +-- A parser for @Maybe a@ attempts to parse @a@, returning @Just x@ if +-- correctly parsed, else @Nothing@. +instance CanParse a => CanParse (Maybe a) where + pars = optional $ try (pars @a) + + -- Note: we override @parsThenMoveToNext@: + -- there will be no spaces to parse if the argument isn't present. + parsThenMoveToNext = + pars >>= \case + Nothing -> return Nothing + Just val -> Just val <$ (eof <|> skipSpace1) + +-- A parser for @[a]@ parses any number of @a@s. +instance {-# OVERLAPPABLE #-} CanParse a => CanParse [a] where + pars = many pars + +-- A parser for @Either a b@ attempts to parse @a@, and if that fails then +-- attempts to parse @b@. +instance (CanParse a, CanParse b) => CanParse (Either a b) where + pars = (Left <$> try (pars @a)) <|> (Right <$> pars @b) + +-- TODO: automate creation of tuple instances using TemplateHaskell +instance (CanParse a, CanParse b) => CanParse (a, b) where + pars = do + x <- parsThenMoveToNext @a + y <- pars @b + return (x, y) + +instance (CanParse a, CanParse b, CanParse c) => CanParse (a, b, c) where + pars = do + x <- parsThenMoveToNext @a + y <- parsThenMoveToNext @b + z <- pars @c + return (x, y, z) + +instance (CanParse a, CanParse b, CanParse c, CanParse d) => CanParse (a, b, c, d) where + pars = do + x <- parsThenMoveToNext @a + y <- parsThenMoveToNext @b + z <- parsThenMoveToNext @c + w <- pars @d + return (x, y, z, w) + +instance (CanParse a, CanParse b, CanParse c, CanParse d, CanParse e) => CanParse (a, b, c, d, e) where + pars = do + x <- parsThenMoveToNext @a + y <- parsThenMoveToNext @b + z <- parsThenMoveToNext @c + w <- parsThenMoveToNext @d + v <- pars @e + return (x, y, z, w, v) + +instance KnownSymbol s => CanParse (Exactly s) where + pars = chunk (pack $ symbolVal (Proxy :: Proxy s)) >> return Ex + +instance (KnownSymbol err, CanParse x) => CanParse (WithError err x) where + pars = (WErr <$> try (pars @x)) symbolVal (Proxy :: Proxy err) + +-- | Parsing implementation for all integral types +-- Overlappable due to the really flexible head state +instance {-# OVERLAPPABLE #-} (Integral a, Read a) => CanParse a where + pars = integer + +instance CanParse Double where + pars = double + +instance CanParse () where + pars = eof + +instance CanParse Snowflake where + pars = Snowflake . fromInteger <$> posInteger + +instance IsString a => CanParse (RestOfInput a) where + pars = ROI . fromString <$> untilEnd + +instance IsString a => CanParse (RestOfInput1 a) where + pars = ROI1 . fromString <$> untilEnd1 + +-- | Parse a labelled value, by parsing the base value and adding the label +-- values. +instance (CanParse a) => CanParse (Labelled n d a) where + pars = labelValue <$> pars + +-- | @noArguments@ is a type-specific alias for @parseComm@ for commands that +-- have no arguments (thus making it extremely clear). +noArguments :: (Message -> EnvDatabaseDiscord d ()) -> Parser (Message -> EnvDatabaseDiscord d ()) +noArguments = parseComm diff --git a/src/Tablebot/Utility/SmartParser/Types.hs b/src/Tablebot/Utility/SmartParser/Types.hs new file mode 100644 index 00000000..bd8b3bfa --- /dev/null +++ b/src/Tablebot/Utility/SmartParser/Types.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Tablebot.Utility.SmartParser.Types +-- Description : Some of the types or typeclasses for smart parsers. +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +module Tablebot.Utility.SmartParser.Types where + +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import Discord.Types +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Tablebot.Utility.Types +import Text.Megaparsec (observing) + +newtype SenderUserId = SenderUserId UserId deriving (Show, Eq) + +-- | Custom infix operator to replace the error of a failing parser (regardless +-- of parser position) with a user given error message. +-- +-- Has some effects on other error parsing. Use if you want the error you give +-- to be the one that is reported (unless this is used at a higher level.) +-- +-- Overwrites/overpowers WithError errors. +() :: Parser a -> String -> Parser a +() p s = do + r <- observing p + case r of + Left _ -> fail s + Right a -> return a + +-- | @Quoted a@ defines an input of type @a@ that is contained within quotes. +newtype Quoted a = Qu {quote :: a} deriving (Show) + +-- | @RestOfInput a@ parses the rest of the input, giving a value of type @a@. +newtype RestOfInput a = ROI {unROI :: a} + +-- | @Exactly s@ defines an input exactly matching @s@ and nothing else. +data Exactly (s :: Symbol) = Ex + +-- | @RestOfInput a@ parses the rest of the input, giving a value of type @a@. +newtype RestOfInput1 a = ROI1 a + +-- | @WithError err x@ parses an @x@, reporting @err@ if the parsing of @x@ +-- fails. +newtype WithError (err :: Symbol) x = WErr x + +-- | Labelled value for use with smart commands. +-- +-- This is for use with slash commands, where there is a name and description +-- required. +newtype Labelled (name :: Symbol) (desc :: Symbol) a = Labelled {unLabel :: a} + +-- | Easily make a labelled value. +labelValue :: forall n d a. a -> Labelled n d a +labelValue = Labelled @n @d + +-- | Get the name and description of a labelled value. +getLabelValues :: forall n d a. (KnownSymbol n, KnownSymbol d) => Proxy (Labelled n d a) -> (Text, Text) +getLabelValues _ = (pack (symbolVal (Proxy :: Proxy n)), pack (symbolVal (Proxy :: Proxy d))) diff --git a/src/Tablebot/Utility/Types.hs b/src/Tablebot/Utility/Types.hs index 2bb83d11..34002f27 100644 --- a/src/Tablebot/Utility/Types.hs +++ b/src/Tablebot/Utility/Types.hs @@ -15,25 +15,20 @@ module Tablebot.Utility.Types where import Control.Concurrent.MVar (MVar) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT) -import Data.Char (toLower) +import Data.ByteString (ByteString) +import Data.Default (Default (def)) import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Version.Extra (Version) import Data.Void (Void) import Database.Persist.Sqlite (Migration, SqlPersistM, SqlPersistT) -import Discord (DiscordHandler) +import Discord (DiscordHandler, restCall) +import Discord.Interactions +import Discord.Internal.Rest.Channel (MessageDetailedOpts (MessageDetailedOpts)) +import qualified Discord.Requests as R import Discord.Types - ( ChannelId, - Emoji, - Event (..), - Message, - MessageId, - ReactionInfo, - ) -import Safe.Exact (dropExactMay, takeExactMay) import Text.Megaparsec (Parsec) -import Text.Read (readMaybe) -- * DatabaseDiscord @@ -54,6 +49,7 @@ type Database d = SqlPersistM d data TablebotCache = TCache { cacheKnownEmoji :: Map Text Emoji, + cacheApplicationCommands :: Map ApplicationCommandId (Interaction -> EnvDatabaseDiscord () ()), cacheVersionInfo :: VersionInfo } @@ -83,8 +79,8 @@ liftDiscord = lift . lift . lift -- Each feature is its own type, and the features are combined via records into -- full plugins. --- | For when you get a 'MessageCreate'. Checks that the @name@ is directly --- after the bot prefix, and then runs @commandParser@ on it. +-- | For when the plugin is first used, to ensure that certain data is +-- available. newtype StartUp d = StartUp { -- | An action to run at startup startAction :: Database d @@ -92,20 +88,23 @@ newtype StartUp d = StartUp -- | For when you get a 'MessageCreate'. Checks that the @name@ is directly -- after the bot prefix, and then runs @commandParser@ on it. --- It will first try to match against any subcommands, and if that fails it runs the commandParser +-- It will first try to match against any subcommands, and if that fails it runs +-- the commandParser. data EnvCommand d = Command { -- | The name of the command. - name :: Text, + commandName :: Text, -- | A parser to run on the command arguments, returning a computation to -- run in 'DatabaseDiscord'. commandParser :: Parser (Message -> EnvDatabaseDiscord d ()), - -- | A list of subcommands to attempt to parse before the bare command, matching their name. - subcommands :: [EnvCommand d] + -- | A list of subcommands to attempt to parse before the bare command, + -- matching their name. + commandSubcommands :: [EnvCommand d] } type Command = EnvCommand () --- | Construct an aliased command that behaves the same as another command (for things like short forms) +-- | Construct an aliased command that behaves the same as another command (for +-- things like short forms). commandAlias :: Text -> EnvCommand d -> EnvCommand d commandAlias name' (Command _ cp sc) = Command name' cp sc @@ -150,7 +149,34 @@ newtype EnvReactionDel d = ReactionDel onReactionDelete :: ReactionInfo -> EnvDatabaseDiscord d () } -type ReactionDel = EnvReactionAdd () +type ReactionDel = EnvReactionDel () + +-- | Handles the creation of an application command and of the action to be +-- performed once that application command is received. +-- +-- This handles things like chat input (slash commands), message commands, or +-- user commands. The `applicationCommand` is the data structure that +-- represents the application command, and the `applicationCommandRecv` is the +-- action to be performed when this application command is received. +data EnvApplicationCommandRecv d = ApplicationCommandRecv + { -- | The application command to be created. + applicationCommand :: CreateApplicationCommand, + -- | The action to run when the application command is received. + applicationCommandRecv :: Interaction -> EnvDatabaseDiscord d () + } + +type ApplicationCommandRecv = EnvApplicationCommandRecv () + +-- | Handles recieving of components, such as buttons or select menus. +-- +-- The name is the name of the component within a plugin. Choose something +-- unique within the plugin. +data EnvComponentRecv d = ComponentRecv + { componentName :: Text, + onComponentRecv :: Interaction -> EnvDatabaseDiscord d () + } + +type ComponentRecv = EnvComponentRecv () -- | Handles events not covered by the other kinds of features. This is only -- relevant to specific admin functionality, such as the deletion of channels. @@ -178,16 +204,18 @@ data EnvCronJob d = CronJob type CronJob = EnvCronJob () -- | A feature for generating help text --- Each help text page consists of a explanation body, as well as a list of sub-pages --- that display the short text for its page +-- Each help text page consists of a explanation body, as well as a list of +-- sub-pages that display the short text for its page data HelpPage = HelpPage { -- | The [sub]command name helpName :: Text, -- | List of aliases for this command helpAliases :: [Text], - -- | The text to show when listed in a subpage list. Will be prefixed by its helpName + -- | The text to show when listed in a subpage list. Will be prefixed by its + -- helpName helpShortText :: Text, - -- | The text to show when specifically listed. Appears above the list of subpages + -- | The text to show when specifically listed. Appears above the list of + -- subpages helpBody :: Text, -- | A list of help pages that can be recursively accessed helpSubpages :: [HelpPage], @@ -196,78 +224,6 @@ data HelpPage = HelpPage } deriving (Show) --- | Colour names --- Colour is a bit of a mess on discord embeds. --- I've here stolen the pallet list from https://gist.github.com/thomasbnt/b6f455e2c7d743b796917fa3c205f812 -data DiscordColour - = RGB Integer Integer Integer - | Default - | Aqua - | DarkAqua - | Green - | DarkGreen - | Blue - | DarkBlue - | Purple - | DarkPurple - | LuminousVividPink - | DarkVividPink - | Gold - | DarkGold - | Orange - | DarkOrange - | Red - | DarkRed - | Gray - | DarkGray - | DarkerGray - | LightGray - | Navy - | DarkNavy - | Yellow - | DiscordWhite - | DiscordBlurple - | DiscordGrayple - | DiscordDarkButNotBlack - | DiscordNotQuiteBlack - | DiscordGreen - | DiscordYellow - | DiscordFuschia - | DiscordRed - | DiscordBlack - --- | @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 <- takeExactMay 2 h >>= toDec - g <- dropExactMay 2 h >>= takeExactMay 2 >>= toDec - b <- dropExactMay 4 h >>= toDec - return (r, g, b) - where - 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] - --- | @hexToDiscordColour@ converts a potential hex string into a DiscordColour, --- evaluating to Default if it fails. -hexToDiscordColour :: String -> DiscordColour -hexToDiscordColour hex = - let (r, g, b) = fromMaybe (0, 0, 0) $ hexToRGB hex - in RGB r g b - -- | Automatic handling of command permissions -- @UserPermission@ models the current permissions of the user -- @RequiredPermission@ models the permissions required to run a command. @@ -300,11 +256,13 @@ data RequiredPermission = None | Any | Exec | Moderator | Both | Superuser deriv data EnvPlugin d = Pl { pluginName :: Text, startUp :: StartUp d, + applicationCommands :: [EnvApplicationCommandRecv d], commands :: [EnvCommand d], inlineCommands :: [EnvInlineCommand d], onMessageChanges :: [EnvMessageChange d], onReactionAdds :: [EnvReactionAdd d], onReactionDeletes :: [EnvReactionDel d], + onComponentRecvs :: [EnvComponentRecv d], otherEvents :: [EnvOther d], cronJobs :: [EnvCronJob d], helpPages :: [HelpPage], @@ -320,7 +278,92 @@ type Plugin = EnvPlugin () -- Examples of this in use can be found in the imports of -- "Tablebot.Plugins". plug :: Text -> Plugin -plug name' = Pl name' (StartUp (return ())) [] [] [] [] [] [] [] [] [] +plug name' = Pl name' (StartUp (return ())) [] [] [] [] [] [] [] [] [] [] [] envPlug :: Text -> StartUp d -> EnvPlugin d -envPlug name' startup = Pl name' startup [] [] [] [] [] [] [] [] [] +envPlug name' startup = Pl name' startup [] [] [] [] [] [] [] [] [] [] [] + +messageDetailsBasic :: Text -> MessageDetails +messageDetailsBasic t = MessageDetails Nothing (Just t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance Default MessageDetails where + def = MessageDetails Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | This data structure as a convenient way to make either interaction responses +-- or just plain messages. It is used in cases that we're either gonna return +-- an interaction or a message. +data MessageDetails = MessageDetails + { messageDetailsTTS :: Maybe Bool, + messageDetailsContent :: Maybe Text, + messageDetailsEmbeds :: Maybe [CreateEmbed], + messageDetailsFile :: Maybe (Text, ByteString), + messageDetailsAllowedMentions :: Maybe AllowedMentions, + messageDetailsFlags :: Maybe InteractionResponseMessageFlags, + messageDetailsReference :: Maybe MessageReference, + messageDetailsComponents :: Maybe [ActionRow], + messageDetailsAttachments :: Maybe [Attachment], + messageDetailsStickerIds :: Maybe [StickerId] + } + deriving (Show) + +makeEphermeral :: MessageDetails -> MessageDetails +makeEphermeral m = m {messageDetailsFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]} + +convertMessageFormatInteraction :: MessageDetails -> InteractionResponseMessage +convertMessageFormatInteraction MessageDetails {..} = + InteractionResponseMessage + messageDetailsTTS + messageDetailsContent + messageDetailsEmbeds + messageDetailsAllowedMentions + messageDetailsFlags + messageDetailsComponents + messageDetailsAttachments + +convertMessageFormatBasic :: MessageDetails -> MessageDetailedOpts +convertMessageFormatBasic MessageDetails {..} = + MessageDetailedOpts + (fromMaybe "" messageDetailsContent) + (fromMaybe False messageDetailsTTS) + messageDetailsEmbeds + messageDetailsFile + messageDetailsAllowedMentions + messageDetailsReference + messageDetailsComponents + messageDetailsStickerIds + +-- | The type class representing some data we can extract data from. +-- Needed for things like getting a GuildMember, message id, guild id. +-- +-- Only defined for Message and Interaction. +class Context a where + contextUserId :: a -> UserId + contextGuildId :: a -> EnvDatabaseDiscord s (Maybe GuildId) + contextMember :: a -> Maybe GuildMember + contextMessageId :: a -> Maybe MessageId + +instance Context Message where + contextUserId = userId . messageAuthor + contextGuildId m = case messageGuildId m of + Just a -> pure $ Just a + Nothing -> do + let chanId = messageChannelId m + channel <- liftDiscord . restCall $ R.GetChannel chanId + case fmap channelGuild channel of + Right a -> pure $ Just a + Left _ -> pure Nothing + contextMember = messageMember + contextMessageId = return . messageId + +instance Context Interaction where + -- this is safe to do because we are guaranteed to get either a user or a member + contextUserId i = maybe 0 userId (either memberUser Just mor) + where + (MemberOrUser mor) = interactionUser i + contextGuildId i = return $ interactionGuildId i + contextMember i = case interactionUser i of + (MemberOrUser (Left m)) -> return m + (MemberOrUser (Right _)) -> Nothing + contextMessageId InteractionComponent {interactionMessage = m} = return $ messageId m + contextMessageId InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataMessage {..}} = return applicationCommandDataTargetMessageId + contextMessageId _ = Nothing diff --git a/src/Tablebot/Utility/Utils.hs b/src/Tablebot/Utility/Utils.hs index 182f0e74..54c660ab 100644 --- a/src/Tablebot/Utility/Utils.hs +++ b/src/Tablebot/Utility/Utils.hs @@ -10,6 +10,7 @@ module Tablebot.Utility.Utils where import Control.Monad (when) +import Data.Proxy (Proxy (Proxy)) import Data.Text (Text, filter, toLower) import Data.Text.ICU.Char (Bool_ (Diacritic), property) import Data.Text.ICU.Normalize (NormalizationMode (NFD), normalize) @@ -48,6 +49,9 @@ standardise x = filter (not . property Diacritic) normalizedText maybeEmptyPrepend :: Text -> Maybe Text -> Text maybeEmptyPrepend s = maybe "" (s <>) +mkProxy :: forall a. a -> Proxy a +mkProxy _ = Proxy :: Proxy a + newtype DebugString = DStr String instance Show DebugString where diff --git a/stack.yaml b/stack.yaml index 609331c0..619f14bd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,32 +42,32 @@ packages: # allow-newer: true extra-deps: - - discord-haskell-1.10.0 - - emoji-0.1.0.2 - - load-env-0.2.1.0 - - megaparsec-9.0.1 - - persistent-2.11.0.4 - - persistent-sqlite-2.11.1.0 - - persistent-template-2.9.1.0@rev:2 - - esqueleto-3.4.1.1 - - duckling-0.2.0.0 - - dependent-sum-0.7.1.0 - - constraints-extras-0.3.1.0 - - Chart-diagrams-1.9.3 - - SVGFonts-1.7.0.1 - - diagrams-core-1.5.0 - - diagrams-lib-1.4.5.1 - - diagrams-postscript-1.5.1 - - diagrams-svg-1.4.3.1 - - svg-builder-0.1.1 - - active-0.2.0.15 - - dual-tree-0.2.3.0 - - monoid-extras-0.6.1 - - statestack-0.3 - - diagrams-rasterific-1.4.2.2 - # - distribution-1.1.1.1 - - git: https://github.com/L0neGamer/haskell-distribution.git - commit: 569d6452e4bffedb2c0d3795885fccdb22a4d29d +- discord-haskell-1.14.0 +- emoji-0.1.0.2 +- load-env-0.2.1.0 +- megaparsec-9.0.1 +- persistent-2.11.0.4 +- persistent-sqlite-2.11.1.0 +- persistent-template-2.9.1.0@rev:2 +- esqueleto-3.4.1.1 +- duckling-0.2.0.0 +- dependent-sum-0.7.1.0 +- constraints-extras-0.3.1.0 +- Chart-diagrams-1.9.3 +- SVGFonts-1.7.0.1 +- diagrams-core-1.5.0 +- diagrams-lib-1.4.5.1 +- diagrams-postscript-1.5.1 +- diagrams-svg-1.4.3.1 +- svg-builder-0.1.1 +- active-0.2.0.15 +- dual-tree-0.2.3.0 +- monoid-extras-0.6.1 +- statestack-0.3 +- diagrams-rasterific-1.4.2.2 +# - distribution-1.1.1.1 +- git: https://github.com/L0neGamer/haskell-distribution.git + commit: 569d6452e4bffedb2c0d3795885fccdb22a4d29d # Override default flag values for local packages and extra-deps # flags: {} diff --git a/tutorials/3.Interactions.md b/tutorials/3.Interactions.md new file mode 100644 index 00000000..47165067 --- /dev/null +++ b/tutorials/3.Interactions.md @@ -0,0 +1,366 @@ +# Making and managing Interactions + +A recent change in Discord added some pretty neat ways of interacting. Unfortunately, it requires a fair amount of fiddling, so let's go through how to use this! + +Below is an example of what we'll be able to produce at the end of this tutorial. + +!["showing the usage of various interactions"](./resources/interactions_example_result.jpg "showing the usage of various interactions") + +## Setup + +We'll start where the [Plugins](./1.Plugins.md) tutorial left off, with the below file. I've removed `myping'`, and commented out most of the file, so we can start from basics and build back up again, as well as added a line to `pingPlugin'` which will help us later. + +```haskell +module Tablebot.Plugins.MyPing (pingPlugin') where + +import Data.Text +import Tablebot.Utility +import Tablebot.Utility.Discord +import Tablebot.Utility.SmartParser +import Database.Persist.TH +import Discord.Types +import Database.Esqueleto +import GHC.Word +import Data.Maybe (catMaybes) +import Discord.Interactions +import Data.Default + +-- share +-- [mkPersist sqlSettings, mkMigrate "pingMigration"] +-- [persistLowerCase| +-- PingCount +-- Primary uid +-- uid Word64 +-- counter Int +-- deriving Show +-- |] + +myPing :: Command +myPing = Command "myping" (noArguments $ \m -> do + sendMessage m "pong") [] + +-- myEcho :: Command +-- myEcho = Command "myecho" (parseComm echoHelp) [] +-- where echoHelp :: RestOfInput Text -> Message -> DatabaseDiscord () +-- echoHelp (ROI t) m = sendMessage m t + +-- myPing'' :: Command +-- myPing'' = Command "cmyping" (parseComm pingDB) [] +-- where pingDB :: Message -> DatabaseDiscord () +-- pingDB m = do +-- let uid = extractFromSnowflake $ userId $ messageAuthor m +-- user <- liftSql $ select $ from $ \p -> do +-- where_ (p ^. PingCountUid ==. val uid) +-- return p +-- c <- case user of +-- [] -> do +-- _ <- liftSql $ insert (PingCount uid 1) +-- return 1 +-- (x : _) -> do +-- let (PingCount uid' count) = entityVal x +-- record' = PingCount uid' (count+1) +-- liftSql $ repsert (entityKey x) record' +-- return (count+1) +-- sendMessage m (pack $ show c) + +pingPlugin' :: Plugin +pingPlugin' = (plug "myping") {commands = [ + myPing + -- , myPing'' + -- , myEcho + ] + -- , migrations = [pingMigration] + , onComponentRecvs = [] + , applicationCommands = catMaybes [] + } +``` + +Additionally, we'll need to choose how our application commands are registered. The quickest and easiest way to do this is to add `SERVER_ID=` to your `.env` file. + +## Slash command basics + +As before, let's start with the simplest type of command - replying to a given command. + +We're going to change up how `myPing` is formed, so we can see how to make both a slash command and a text command. + +First, we separate out the function that responds with `pong`, and make it so that instead of instantly sending the message, it generates a `MessageDetails` data structure that represents such a message. + +```haskell +myPing :: Command +myPing = Command "myping" (parseComm myPingAction) [] + +myPingAction :: DatabaseDiscord MessageDetails +myPingAction = return $ messageDetailsBasic "pong" +``` + +Due to some of the setup that's been done separately, this will work as before, replying with "pong" when we call "myping". + +We can now create our first application command! + +To do this, we have to tell Discord what application command to create, and then we have to come up with a way to answer that. Luckily, we've made some magic to make some of this somewhat easier, and package it all up for us. + +```haskell +myPingInteraction :: Maybe ApplicationCommandRecv +myPingInteraction = makeApplicationCommandPair "myping" "my unique ping" myPingAction +``` + +Here we've (possibly) created an application command called "myping", with a description of "my unique ping" that is created from `myPingAction`. + +If we add `myPingInteraction` to the `applicationCommands` list in `pingPlugin'`, and run our bot, we can see that we can now (after a short delay) type `/myping` into discord, press enter, and get a special response in return. + +Well, that's pretty exciting. But we could do that before. What do we need to do to get the rest of our ping functions up to scratch? + +Turns out there's a fair amount of information that we took for granted before that we're now going to have to work through, but don't worry, we're gonna get through it step by step. + +### Labelled arguments + +Slash commands unfortunately need to have each of their parameters named and described, which means that anything we give to our function has to be named. This can be seen below. + +!["showing the an example slash command"](./resources/interactions_example_labels.jpg "showing an example slash command") + +Let's uncomment `myEcho` and roll up our sleeves to see what we want to do here. + +First we pull out `echoHelp` into its own top level function, modify the return and arguments so it returns a message that is just the text we pass in - and we run into an issue. Having a `RestOfInput` doesn't make any sense in a slash command, so we can't use `echoHelp` as is. We're going to have to construct two subtly different functions that we can process differently to get what we want. + +```haskell +-- current `echoHelp` +echoHelp :: RestOfInput Text -> DatabaseDiscord MessageDetails +echoHelp (ROI t) = return $ messageDetailsBasic t +``` + +We take away the restriction of `RestOfInput` for now, breaking `myecho`, but we'll fix it shortly. + +We then change `myEcho` so that instead of having `(parseComm echoHelp)`, we instead have `(parseComm (echoHelp . unROI))`. This function is now the same as it originally was, and we can reuse our new `echoHelp` for our interactions. `unROI` lets us get the value within a `RestOfInput` value; its usage here effectively tells `parseComm` "Hey, get a `RestOfInput`, unwrap it, and feed it to `echoHelp`". + +```haskell +myEcho :: Command +myEcho = Command "myecho" (parseComm (echoHelp . unROI)) [] + +echoHelp :: Text -> DatabaseDiscord MessageDetails +echoHelp t = return $ messageDetailsBasic t +``` + +Ok, great, we're back to where we started. Now we have to make this labelled interactiony thingummy. + +Let's see if we can just do the same thing we just did, using the tools we had before. + +```haskell +myEchoInteraction :: Maybe ApplicationCommandRecv +myEchoInteraction = makeApplicationCommandPair "myecho" "echo your input" (echoHelp . unLabel) +``` + +Alright, and compi- + +``` +No instance for (GHC.TypeLits.KnownSymbol name0) + arising from a use of ‘makeApplicationCommandPair’ + • In the expression: + makeApplicationCommandPair + "myecho" "echo your input" (echoHelp . unLabel) + In an equation for ‘myEchoInteraction’: + myEchoInteraction + = makeApplicationCommandPair + "myecho" "echo your input" (echoHelp . unLabel) +``` + +Oh dear that's hideous. Oh yeah, we forget to actually label anything! Labelling means we name and describe each argument we're giving to this function. + +We can achieve this in one of two ways. Firstly, we could create a function which has the labels we want and then make the slash command like that; secondly, we could use type applications to add the labels we want here. I'm going to go with the latter in this case, but I'll show both here. `Labelled` is provided by `Tablebot` to do some clever things in the command parsing - it groups a value with a label and a description. + +```haskell +myEchoInteraction1 :: Maybe ApplicationCommandRecv +myEchoInteraction1 = makeApplicationCommandPair "myecho" "echo your input" echoHelp' + where + echoHelp' :: Labelled "message" "the message to echo back" Text -> DatabaseDiscord MessageDetails + echoHelp' (Labelled t) = echoHelp t + +myEchoInteraction2 :: Maybe ApplicationCommandRecv +myEchoInteraction2 = makeApplicationCommandPair "myecho" "echo your input" (echoHelp . unLabel @"message" @"the message to echo back") +``` + +Adding this new construction to our `applicationCommands` list and running the bot results in a new application command, one which can a single text input which the bot then throws right back at us. + +### Users + +One of the most useful bits of information that we would want to get is the user id of the user that called a command. Removing the reliance on `Message` means that we, unfortunately, don't have that information any more. We have a solution to this though! And we'll work through using that solution with `myping''`, which was the ping example that counted the number of times it had been pinged by the user before. + +As before, we'll start by moving the helper function (`pingDB`) to its own top level function, changing any message sending to returning a `MessageDetails`, and then removing `Message` from the signature. + +Doing this though, we immediately come up on the snag. Even if we aren't sending a message using `m` any more, we are still getting the user id of the user that sent the message. To solve this, we have to perform a special kind of parsing, using the context we have. This changes the first couple lines of `pingDB` to the following. + +```haskell +pingDB :: SenderUserId -> DatabaseDiscord MessageDetails +pingDB (SenderUserId u) = do + let uid = extractFromSnowflake $ unId u +``` + +We then construct the interaction as we have done before, add it to the interactions, and boom, we have another slash command to work with! + +### Closing off and caveats + +There are some more complex constructions with slash commands (such as subcommands), but as they are currently a bit fiddly we won't cover them in this tutorial. + +Discord also offers user and message application commands, which we haven't created nice interfaces for just yet, but are usable if you do create them. + +## Components + +Another cool thing added was a variety of widgets and gizmos that bots can add to messages called "components". These also use the interaction system to process, but we've abstracted that again. + +First, let's decide what we want to do with this. How about we add to the basic `myping`, and make it so that there's a button that says "Ping!", which people can click and it'll reply "pong"? + +Yes it's contrived, I'm sorry. + +Like before, this is a two stage process. In one place, we have to create the component itself, and in another we have to handle the interaction the component generates. + +Let's create the component itself. We need to add it to the button to be pressed. This isn't too streamlined, but it makes some level of sense. + +A button needs the text it will display, and a unique identifier that we'll use to differentiate and process a button. In this case, those are "Ping!" and "myping pingbutton" (why that exactly I'll explain later). + +```haskell +myPingAction :: DatabaseDiscord MessageDetails +myPingAction = return $ (messageDetailsBasic "pong") { messageDetailsComponents = Just [cps] } + where cps = ActionRowButtons [mkButton "Ping!" "myping pingbutton"] +``` + +Running the bot, we see that we get the button now! But it just loads for a couple seconds then errors. We need our bot to actually handle this button press. + +We can construct and add this component handler by using `processComponentInteraction` and `ComponentRecv`. The first creates a parser like `parseComm` did in the [Plugins](./1.Plugins.md) tutorial and the latter creates the data structure this interaction processor works in. + +The action we use in response to the button will be `myPingAction` as it was before, so we feed that and `False` to `processComponentInteraction`. The `False` means that we send a message, instead of updating a message (see [More complex components](#more-complex-components)). + +The reason I chose "myping pingbutton" as the identifier before is because of how we process and distribute components. The first word of the unique identifier has to be the plugin name, and the second has to be identifier of the particular component being processed. + +```haskell +myPingButton :: ComponentRecv +myPingButton = ComponentRecv "pingbutton" (processComponentInteraction myPingAction False) +``` + +Now we just load `myPingButton` into `onComponentRecvs` in our plugin creation (similar to what we do with other commands), run the bot again, run the command, and press our sparkly button, and we get a message from the bot saying "pong"! + +```haskell +pingPlugin' = (plug "myping") {commands = [ + ... + ] + ... + , onComponentRecvs = [myPingButton] -- This right here, add this + ... + } +``` + +But can we do better? + +### More complex components + +In the [Plugins](./1.Plugins.md) tutorial we created a ping command that stored the ping count of a user in the database. Wouldn't it be useful if we could do the same, but in a button? Well even if it isn't useful, we can! + +For this we're going to have to make a more complex button action, but it should be fine, right? + +First we make it so that the button identifier includes a number at the end, like `"myping pingbutton 0"`. Now we have to update the action on receiving a button press. + +We create a function `myPingButtonAction` that takes a number and the interaction, and with those updates the original message component with that number, and sends a message that says "pong" and the number it is up to. + +```haskell +myPingButtonAction :: Integer -> Interaction -> DatabaseDiscord MessageDetails +myPingButtonAction i inter = do + sendReplyMessage (interactionMessage inter) ("pong " <> pack (show i)) -- respond to the message with a pong + return $ def { messageDetailsComponents = Just [cps] } -- the message to update the original with + where cps = ActionRowButtons [mkButton "Ping!" ("myping pingbutton " <> pack (show (i + 1)))] +``` + +And then we edit `myPingButton` so that it uses the above function and also uses the output from it to update the original message: `ComponentRecv "pingbutton" (processComponentInteraction myPingButtonAction True)`. + +Now when we press the button, we get a pong with a number after it for each time the button has been pressed! Pretty neat, huh? + +## Conclusions + +A lot was missed out of this tutorial, and there's a lot more that we haven't (yet!) made easier to do within `tablebot`, but we hope that this lets you get started on your bot development in Haskell! + +In case you just want the complete working code from this tutorial, here it is. + +```haskell +module Tablebot.Plugins.MyPing (pingPlugin') where + +import Data.Text +import Tablebot.Utility +import Tablebot.Utility.Discord +import Tablebot.Utility.SmartParser +import Database.Persist.TH +import Discord.Types +import Database.Esqueleto +import GHC.Word +import Data.Maybe (catMaybes) +import Discord.Interactions +import Data.Default + +share + [mkPersist sqlSettings, mkMigrate "pingMigration"] + [persistLowerCase| +PingCount + Primary uid + uid Word64 + counter Int + deriving Show +|] + +myPing :: Command +myPing = Command "myping" (parseComm myPingAction) [] + +myPingAction :: DatabaseDiscord MessageDetails +myPingAction = return $ (messageDetailsBasic "pong") { messageDetailsComponents = Just [cps] } + where cps = ActionRowButtons [mkButton "Ping!" "myping pingbutton 0"] + +myPingInteraction :: Maybe ApplicationCommandRecv +myPingInteraction = makeApplicationCommandPair "myping" "my unique ping" myPingAction + +myPingButton :: ComponentRecv +myPingButton = ComponentRecv "pingbutton" (processComponentInteraction myPingButtonAction True) + +myPingButtonAction :: Integer -> Interaction -> DatabaseDiscord MessageDetails +myPingButtonAction i inter = do + sendReplyMessage (interactionMessage inter) ("pong " <> pack (show i)) + return $ def { messageDetailsComponents = Just [cps] } + where cps = ActionRowButtons [mkButton "Ping!" ("myping pingbutton " <> pack (show (i + 1)))] + +myEcho :: Command +myEcho = Command "myecho" (parseComm (echoHelp . unROI)) [] + +echoHelp :: Text -> DatabaseDiscord MessageDetails +echoHelp t = return $ messageDetailsBasic t + +myEchoInteraction :: Maybe ApplicationCommandRecv +myEchoInteraction = makeApplicationCommandPair "myecho" "echo your input" (echoHelp . unLabel @"message" @"the message to echo back") + +myPing'' :: Command +myPing'' = Command "cmyping" (parseComm pingDB) [] + +pingDB :: SenderUserId -> DatabaseDiscord MessageDetails +pingDB (SenderUserId u) = do + let uid = extractFromSnowflake $ unId u + user <- liftSql $ select $ from $ \p -> do + where_ (p ^. PingCountUid ==. val uid) + return p + c <- case user of + [] -> do + _ <- liftSql $ insert (PingCount uid 1) + return 1 + (x : _) -> do + let (PingCount uid' count) = entityVal x + record' = PingCount uid' (count+1) + liftSql $ repsert (entityKey x) record' + return (count+1) + return $ messageDetailsBasic (pack $ show c) + +myPingInteraction'' :: Maybe ApplicationCommandRecv +myPingInteraction'' = makeApplicationCommandPair "cmyping" "counting pings" pingDB + +pingPlugin' :: Plugin +pingPlugin' = (plug "myping") {commands = [ + myPing + , myPing'' + , myEcho + ] + , migrations = [pingMigration] + , onComponentRecvs = [myPingButton] + , applicationCommands = catMaybes [ myPingInteraction, myEchoInteraction, myPingInteraction'' ] + } +``` diff --git a/tutorials/resources/interactions_example_labels.jpg b/tutorials/resources/interactions_example_labels.jpg new file mode 100644 index 00000000..42499e8a Binary files /dev/null and b/tutorials/resources/interactions_example_labels.jpg differ diff --git a/tutorials/resources/interactions_example_result.jpg b/tutorials/resources/interactions_example_result.jpg new file mode 100644 index 00000000..edb1e181 Binary files /dev/null and b/tutorials/resources/interactions_example_result.jpg differ