From dcef0b65069fb38fd0f6c4382353167f603ebff1 Mon Sep 17 00:00:00 2001
From: LLLL Colonq <llll@colonq>
Date: Thu, 16 Nov 2023 19:06:43 -0500
Subject: Initial commit

---
 .../examples/interaction-commands-simple.hs        | 125 +++++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 deps/discord-haskell/examples/interaction-commands-simple.hs

(limited to 'deps/discord-haskell/examples/interaction-commands-simple.hs')

diff --git a/deps/discord-haskell/examples/interaction-commands-simple.hs b/deps/discord-haskell/examples/interaction-commands-simple.hs
new file mode 100644
index 0000000..bf46321
--- /dev/null
+++ b/deps/discord-haskell/examples/interaction-commands-simple.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Discord
+import Discord.Types
+import Discord.Interactions
+import UnliftIO (liftIO)
+import Data.List (find)
+import Control.Monad (forM_)
+import ExampleUtils (getToken, getGuildId)
+import Data.Text (Text)
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO)
+import qualified Discord.Requests as R
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+
+
+-- MAIN
+
+main :: IO ()
+main = do
+  tok <- getToken
+  testGuildId <- getGuildId
+
+  botTerminationError <- runDiscord $ def
+    { discordToken = tok
+    , discordOnEvent = onDiscordEvent testGuildId
+    -- If you are using application commands, you might not need
+    -- message contents at all
+    , discordGatewayIntent = def { gatewayIntentMessageContent = False }
+    }
+
+  echo $ "A fatal error occurred: " <> botTerminationError
+
+
+-- UTILS
+
+echo :: MonadIO m => Text -> m ()
+echo = liftIO . TIO.putStrLn
+
+showT :: Show a => a -> Text
+showT = T.pack . show
+
+
+-- COMMANDS
+
+data SlashCommand = SlashCommand
+  { name :: Text
+  , registration :: Maybe CreateApplicationCommand
+  , handler :: Interaction -> Maybe OptionsData -> DiscordHandler ()
+  }
+
+mySlashCommands :: [SlashCommand]
+mySlashCommands = [ping]
+
+ping :: SlashCommand
+ping = SlashCommand
+  { name = "ping"
+  , registration = createChatInput "ping" "responds pong"
+  , handler = \intr _options ->
+      void . restCall $
+        R.CreateInteractionResponse
+          (interactionId intr)
+          (interactionToken intr)
+          (interactionResponseBasic  "pong")
+  }
+
+
+-- EVENTS
+
+onDiscordEvent :: GuildId -> Event -> DiscordHandler ()
+onDiscordEvent testGuildId = \case
+  Ready _ _ _ _ _ _ (PartialApplication appId _) -> onReady appId testGuildId
+  InteractionCreate intr                         -> onInteractionCreate intr
+  _                                              -> pure ()
+
+onReady :: ApplicationId -> GuildId -> DiscordHandler ()
+onReady appId testGuildId = do
+  echo "Bot ready!"
+
+  appCmdRegistrations <- mapM tryRegistering mySlashCommands
+
+  case sequence appCmdRegistrations of
+    Left err ->
+      echo $ "[!] Failed to register some commands" <> showT err
+
+    Right cmds -> do
+      echo $ "Registered " <> showT (length cmds) <> " command(s)."
+      unregisterOutdatedCmds cmds
+
+  where
+  tryRegistering cmd = case registration cmd of
+    Just reg -> restCall $ R.CreateGuildApplicationCommand appId testGuildId reg
+    Nothing  -> pure . Left $ RestCallErrorCode 0 "" ""
+
+  unregisterOutdatedCmds validCmds = do
+    registered <- restCall $ R.GetGuildApplicationCommands appId testGuildId
+    case registered of
+      Left err ->
+        echo $ "Failed to get registered slash commands: " <> showT err
+
+      Right cmds ->
+        let validIds    = map applicationCommandId validCmds
+            outdatedIds = filter (`notElem` validIds)
+                        . map applicationCommandId
+                        $ cmds
+         in forM_ outdatedIds $
+              restCall . R.DeleteGuildApplicationCommand appId testGuildId
+
+onInteractionCreate :: Interaction -> DiscordHandler ()
+onInteractionCreate = \case
+  cmd@InteractionApplicationCommand
+    { applicationCommandData = input@ApplicationCommandDataChatInput {} } ->
+      case
+        find (\c -> applicationCommandDataName input == name c) mySlashCommands
+      of
+        Just found ->
+          handler found cmd (optionsData input)
+
+        Nothing ->
+          echo "Somehow got unknown slash command (registrations out of date?)"
+
+  _ ->
+    pure () -- Unexpected/unsupported interaction type
-- 
cgit v1.2.3