oscar-h64 · oscar-h64 · Jun 25, 2020 · Jul 10, 2020 · Jul 11, 2020 · Aug 13, 2020
diff --git a/README.md b/README.md
@@ -25,7 +25,7 @@ This is a discord bot written in Haskell using the [calamity library](https://ha
 See [here](https://github.com/oscar-h64/calamity-admin-bot/issues?q=is%3Aissue+is%3Aopen+label%3Aenhancement) for a list of features planned. If there is a feature you would like feel free to open an issue (or a pull request!) with the label `enhancement` 
 
 ## Setup
-1. Copy `config/settings.yaml.sample` to `config/settings.yaml` and enter the settings for your server (the file is commented to assist with this)
+1. Copy `config/settings.sample.yaml` to `config/settings.yaml` and enter the settings for your server (the file is commented to assist with this)
 2. Install the Haskell `stack` tool - see [here](https://docs.haskellstack.org/en/stable/install_and_upgrade/)
 3. Clone this repository:
 ```bash

diff --git a/app/Main.hs b/app/Main.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE GADTs #-}
 --------------------------------------------------------------------------------
 -- Calamity Admin Bot                                                         --
 --------------------------------------------------------------------------------
@@ -7,99 +6,122 @@
 --                                                                            --
 -- Copyright 2020 Oscar Harris (oscar@oscar-h.com)                            --
 --------------------------------------------------------------------------------
+
 {-# LANGUAGE TypeApplications #-}
 
 module Main where
 
+--------------------------------------------------------------------------------
+
+import           Calamity.Cache.InMemory        ( runCacheInMemory )
 import           Calamity.Commands
-import           Calamity.Commands.CommandUtils             ( CommandForParsers, TypedCommandC )
-import           Calamity.Commands.Command                  ( Command )
-import           Calamity.Cache.InMemory                    ( runCacheInMemory )
-import           Calamity.Metrics.Noop                      ( runMetricsNoop )
+import           Calamity.Commands.Command      ( Command )
+import           Calamity.Commands.CommandUtils ( CommandForParsers,
+                                                  TypedCommandC )
+import           Calamity.Metrics.Noop          ( runMetricsNoop )
 
-import qualified Data.Text.Lazy                             as L
-import           Data.Yaml                                  ( prettyPrintParseException, decodeFileEither )
+import qualified Data.Text.Lazy                 as L
+import           Data.Yaml                      ( decodeFileEither,
+                                                  prettyPrintParseException )
 
-import qualified Polysemy                                   as P
-import qualified Polysemy.Reader                            as P
+import           Di                             ( new )
+import           DiPolysemy                     ( runDiToIO )
+
+import qualified Polysemy                       as P
+import qualified Polysemy.Reader                as P
 
 import           TextShow
 
-import Bot.Import
-import Bot.Commands
-import Bot.Commands.Check
-import Bot.Events
+import           Bot.Commands
+import           Bot.Commands.Check
+import           Bot.Events
+import           Bot.Import
+
+--------------------------------------------------------------------------------
+
+-- | `botCommands` @toMuteRoles@ represents a list of commands the bot supports.
+-- Mute related commands are restricted to users with at least one role from the
+-- roles represented by @toMuteRoles@
+botCommands :: (BotReader r, P.Member ParsePrefix r)
+            => [Snowflake Role]
+            -> Sem (DSLState r) Command
+botCommands toMuteRoles = do
+    -- Help command
+    helpCommand
+
+    -- Ping Command
+    help (const "Replies with 'pong'") $
+        command @'[] "ping" ping
+
+    -- Invite command
+    help (const "Returns the invite link to the server") $
+        command @'[] "invite" invite
+
+    -- User Mute
+    muteCheck toMuteRoles $ help (const "Mutes the given user for the given reason") $
+        command @'[Snowflake User, ActionReason] "mute" Bot.Commands.mute
+
+    -- User Tempmute
+    muteCheck toMuteRoles $ help (const "Mutes the given user for the given time for the given reason") $
+        command @'[Snowflake User, Text, ActionReason] "tempmute" tempmute
+
+    -- User Unmute
+    muteCheck toMuteRoles $ help (const "Unmutes the given user for the given reason") $
+        command @'[Snowflake User, ActionReason] "unmute" unmute
+
+    -- User Ban
+    banCheck $ help (const "Bans the given user for the given reason") $
+        command @'[Snowflake User, ActionReason] "ban" ban
+
+    -- User Unban
+    banCheck $ help (const "Unbans the given user for the given reason") $
+        command @'[Snowflake User, ActionReason] "unban" unban
+
+    -- Bulk user ban
+    banCheck $ help (const "Bans the given users for the given reason") $
+        command @'[[Snowflake User], ActionReason] "bulkban" bulkban
+
+    -- User Kick
+    kickCheck $ help (const "Kicks the given user for the given reason") $
+        command @'[Snowflake User, ActionReason] "kick" kick
 
 runBot :: BotConfig -> IO ()
-runBot conf = void . P.runFinal . P.embedToFinal . runCacheInMemory . runMetricsNoop . useConstantPrefix "!"
-        $ runBotIO (bcBotSecret conf) $ P.runReader conf $ do
-            -- Commands:
-            addCommands $ do
-                -- Help command
-                helpCommand
-
-                -- Ping Command
-                help (const "Replies with 'pong'") $
-                    command @'[] "ping" ping
-
-                -- Invite command
-                help (const "Returns the invite link to the server") $
-                    command @'[] "invite" invite
-
-                -- User Mute
-                muteCheck (bcToMuteRoles conf) <$> help (const "Mutes the given user for the given reason") $
-                    command @'[Snowflake User, ActionReason] "mute" Bot.Commands.mute
-
-                -- User Tempmute
-                muteCheck (bcToMuteRoles conf) <$> help (const "Mutes the given user for the given time for the given reason") $
-                    command @'[Snowflake User, Text, ActionReason] "tempmute" tempmute
-
-                -- User Unmute
-                muteCheck (bcToMuteRoles conf) $ help (const "Unmutes the given user for the given reason") $
-                    command @'[Snowflake User, ActionReason] "unmute" unmute
-
-                -- User Ban
-                banCheck $ help (const "Bans the given user for the given reason") $
-                    command @'[Snowflake User, ActionReason] "ban" ban
-
-                -- User Unban
-                banCheck $ help (const "Unbans the given user for the given reason") $
-                    command @'[Snowflake User, ActionReason] "unban" unban
-
-                -- Bulk user ban
-                banCheck $ help (const "Bans the given users for the given reason") $
-                    command @'[[Snowflake User], ActionReason] "bulkban" bulkban
-
-                -- User Kick
-                kickCheck $ help (const "Kicks the given user for the given reason") $
-                    command @'[Snowflake User, ActionReason] "kick" kick
-
-            -- Event Handlers:
-            -- Ready:
-            react @'ReadyEvt onReady
-
-            -- Message Create:
-            react @'MessageCreateEvt onMessageCreate
-
-            -- Message Edit:
-            react @'MessageUpdateEvt $ uncurry onMessageEdit
-
-            -- Message Delete:
-            react @'MessageDeleteEvt onMessageDelete
-
-            -- Command Error Event
-            react @('CustomEvt "command-error" (CommandContext, CommandError)) $ \(ctx, e) -> do
-                info $ "Command failed with reason: " <> showt e
-                case e of
-                    ParseError n r -> void . tellt ctx $ 
-                        "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```"
-                    CheckError n r -> void . tellt ctx $ 
-                        "The following check failed: " <> codeline (L.fromStrict n) <> ", with reason: " <> codeblock' Nothing r
+runBot conf = new $ \di -> 
+    void . P.runFinal . P.embedToFinal . runDiToIO di . runCacheInMemory . runMetricsNoop . useConstantPrefix "!"
+    $ runBotIO (bcBotSecret conf) $ P.runReader conf $ do
+        -- Commands:
+        addCommands $ botCommands $ bcToMuteRoles conf
+
+        -- Event Handlers:
+        -- Ready:
+        react @'ReadyEvt onReady
+
+        -- Message Create:
+        react @'MessageCreateEvt onMessageCreate
+
+        -- Message Edit:
+        react @'MessageUpdateEvt $ uncurry onMessageEdit
+
+        -- Message Delete:
+        react @'MessageDeleteEvt onMessageDelete
+
+        -- Reaction Added:
+        react @'RawMessageReactionAddEvt onReactionAdd
+
+        -- Command Error Event
+        react @('CustomEvt "command-error" (CommandContext, CommandError)) $ \(ctx, e) -> do
+            info $ "Command failed with reason: " <> showt e
+            case e of
+                ParseError n r -> void . tellt ctx $
+                    "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```"
+                CheckError n r -> void . tellt ctx $
+                    "The following check failed: " <> codeline (L.fromStrict n) <> ", with reason: " <> codeblock' Nothing r
 
 main :: IO ()
 main = do
     conf <- decodeFileEither "config/settings.yaml"
     case conf of
-        Left err -> putStrLn $ prettyPrintParseException err 
+        Left err   -> putStrLn $ prettyPrintParseException err
         Right conf -> runBot conf
-
+
+--------------------------------------------------------------------------------
diff --git a/config/settings.sample.yaml b/config/settings.sample.yaml
@@ -0,0 +1,84 @@
+# Enter your bot secret here
+bot-secret: BOT_SECRET
+
+# Enter the ID of the logging channel here
+log-channel: 000000000000000000
+
+# Enter the ID of the mute role here
+mute-role: 000000000000000000
+
+# Enter the IDs of the roles allowed to mute/tempmute/unmute users
+to-mute-roles:
+- 000000000000000000
+- 000000000000000001
+
+# Enter the server invite link here
+invite-link: https://discord.gg/XXXXXXX
+
+# Enter the name of your server here
+server-name: Example Server
+
+# Enter banned fragments (phrases, words or parts of words) here. To disable
+# content filtering delete this block
+banned-fragments:
+- word1
+- word2
+
+# Enter the details for the bot activity here. If you do not want an activity 
+# then delete this block
+activity:
+  # The type determines the prefix discord adds. Available options:
+  # - Playing
+  # - Listening
+  # - Watching
+  type: Playing
+  # Activity text 
+  text: a game
+
+# Setup react roles here for automatic mode (where the bot sends the message
+# members react to). If you do not want to use this feature delete this block
+react-roles-auto:
+- # description of this role set - used as a heading in the message 
+  description: Courses
+  # channel to send message in
+  channel-id: 000000000000000000
+  # whether members can select more than 1 role in this set
+  only-one: false
+  # roles 
+  roles:
+  - emoji1:
+      # Description of the role assigned by this emoji
+      description: Role 1
+      # ID of the role to assign 
+      role-id: 000000000000000000
+  - emoji2:
+      description: Role 2
+      role-id: 000000000000000001
+
+- description: Accommodation
+  only-one: true
+  roles:
+  - emoji1:
+      description: Role 1
+      role-id: 000000000000000000
+  - emoji2:
+      description: Role 2
+      role-id: 000000000000000001
+
+# Setup react roles here for menual mode (where the bot watches for reactions
+# on a specific existing message). If you do not want to use this feature 
+# delete this block
+react-roles-manual:
+  000000000000000000: # message ID of message to watch
+    # whether members can select more than 1 role
+    only-one: false
+    # roles that can be assigned on this message. Use the emoji name as the
+    # key and the role ID as the value
+    roles:
+      emoji1: 000000000000000000
+      emoji2: 000000000000000001
+  000000000000000001: # message ID of message to watch
+    only-one: true
+    roles:
+      emoji1: 000000000000000000
+      emoji3: 000000000000000001
diff --git a/config/settings.yaml.sample b/config/settings.yaml.sample
diff --git a/hie.yaml b/hie.yaml
@@ -0,0 +1,10 @@
+cradle:
+    stack:
+    - path: './app'
+      component: 'calamity-admin-bot:exe:calamity-admin-bot'
+    - path: './src'
+      component: 'calamity-admin-bot:lib'
+
+dependencies:
+- stack.yaml
+- package.yaml
diff --git a/package.yaml b/package.yaml
@@ -30,12 +30,15 @@ dependencies:
 - data-default
 - colour
 - time
-- vector
+- unboxing-vector
 - data-flags
 - aeson
 - yaml
 - casing
 - suffix-time-reader
+- containers
+- unordered-containers
+- di
 
 default-extensions:
 - OverloadedStrings
@@ -51,6 +54,7 @@ default-extensions:
 - ConstraintKinds
 - GADTs
 - DeriveGeneric
+- RecordWildCards
 
 library:
   source-dirs: src

diff --git a/src/Bot/Commands.hs b/src/Bot/Commands.hs
@@ -6,6 +6,7 @@
 --                                                                            --
 -- Copyright 2020 Oscar Harris (oscar@oscar-h.com)                            --
 --------------------------------------------------------------------------------
+
 module Bot.Commands (
     ping,
     invite,
@@ -18,8 +19,12 @@ module Bot.Commands (
     kick
 ) where
 
-import Bot.Commands.Ping
-import Bot.Commands.Invite
-import Bot.Commands.Mute
+--------------------------------------------------------------------------------
+
 import Bot.Commands.Ban
+import Bot.Commands.Invite
 import Bot.Commands.Kick
+import Bot.Commands.Mute
+import Bot.Commands.Ping
+
+--------------------------------------------------------------------------------