summaryrefslogtreecommitdiff
path: root/deps/discord-haskell/examples/interaction-commands.hs
diff options
context:
space:
mode:
Diffstat (limited to 'deps/discord-haskell/examples/interaction-commands.hs')
-rw-r--r--deps/discord-haskell/examples/interaction-commands.hs483
1 files changed, 483 insertions, 0 deletions
diff --git a/deps/discord-haskell/examples/interaction-commands.hs b/deps/discord-haskell/examples/interaction-commands.hs
new file mode 100644
index 0000000..7d22825
--- /dev/null
+++ b/deps/discord-haskell/examples/interaction-commands.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+import Control.Monad (when)
+import qualified Data.ByteString as B
+import Data.Char (isDigit)
+import Data.Functor ((<&>))
+import Data.List (transpose)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Discord
+import Discord.Interactions
+import qualified Discord.Requests as R
+import Discord.Types
+import UnliftIO (liftIO)
+import UnliftIO.Concurrent
+
+import ExampleUtils (getToken, getGuildId, actionWithChannelId)
+
+main :: IO ()
+main = interactionCommandExample
+
+void :: DiscordHandler (Either RestCallErrorCode b) -> DiscordHandler ()
+void =
+ ( >>=
+ ( \case
+ Left e -> liftIO $ print e
+ Right _ -> return ()
+ )
+ )
+
+-- | Creates and manages a variety of interactions, including a tic tac toe example.
+interactionCommandExample :: IO ()
+interactionCommandExample = do
+ tok <- getToken
+ testserverid <- getGuildId
+
+ -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields
+ t <-
+ runDiscord $
+ def
+ { discordToken = tok,
+ discordOnStart = startHandler testserverid,
+ discordOnEnd = liftIO $ putStrLn "Ended",
+ discordOnEvent = eventHandler testserverid,
+ discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "",
+ discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPresences = True}
+ }
+ TIO.putStrLn t
+
+-- If the start handler throws an exception, discord-haskell will gracefully shutdown
+-- Use place to execute commands you know you want to complete
+startHandler :: GuildId -> DiscordHandler ()
+startHandler testserverid = do
+ let activity =
+ def
+ { activityName = "ping-pong",
+ activityType = ActivityTypeGame
+ }
+ let opts =
+ UpdateStatusOpts
+ { updateStatusOptsSince = Nothing,
+ updateStatusOptsGame = Just activity,
+ updateStatusOptsNewStatus = UpdateStatusOnline,
+ updateStatusOptsAFK = False
+ }
+ sendCommand (UpdateStatus opts)
+
+ actionWithChannelId testserverid $ \cid ->
+ void $
+ restCall $
+ R.CreateMessage
+ cid
+ "Hello! I will reply to pings with pongs"
+
+-- | Example user command
+exampleUserCommand :: Maybe CreateApplicationCommand
+exampleUserCommand = createUser "usercomm"
+
+-- | Example slash command that has subcommands and multiple types of fields.
+newExampleSlashCommand :: Maybe CreateApplicationCommand
+newExampleSlashCommand =
+ createChatInput
+ "subtest"
+ "testing out subcommands"
+ >>= \d ->
+ Just $
+ d
+ { createOptions =
+ Just
+ ( OptionsSubcommands
+ [ OptionSubcommandGroup
+ "frstsubcmdgrp"
+ Nothing
+ "the sub command group"
+ Nothing
+ [ OptionSubcommand
+ "frstsubcmd"
+ Nothing
+ "the first sub sub command"
+ Nothing
+ [ OptionValueString
+ "onestringinput"
+ Nothing
+ "two options"
+ Nothing
+ True
+ ( Right
+ [ Choice "green" Nothing "green",
+ Choice "red" Nothing "red"
+ ]
+ )
+ Nothing
+ Nothing,
+ OptionValueInteger "oneintinput" Nothing "choices galore" Nothing False (Left False) Nothing Nothing
+ ]
+ ],
+ OptionSubcommandOrGroupSubcommand $
+ OptionSubcommand
+ "frstsubcmd"
+ Nothing
+ "the first subcommand"
+ Nothing
+ [ OptionValueString
+ "onestringinput"
+ Nothing
+ "two options"
+ Nothing
+ True
+ ( Right
+ [ Choice "yellow" Nothing "yellow",
+ Choice "blue" Nothing "blue"
+ ]
+ )
+ Nothing
+ Nothing
+ ],
+ OptionSubcommandOrGroupSubcommand $
+ OptionSubcommand
+ "sndsubcmd"
+ Nothing
+ "the second subcommand"
+ Nothing
+ [ OptionValueBoolean
+ "trueorfalse"
+ Nothing
+ "true or false"
+ Nothing
+ True,
+ OptionValueNumber
+ "numbercomm"
+ Nothing
+ "number option"
+ Nothing
+ False
+ (Left True)
+ (Just 3.1415)
+ (Just 101),
+ OptionValueInteger
+ "numbercomm2"
+ Nothing
+ "another number option"
+ Nothing
+ False
+ (Right [Choice "one" Nothing 1, Choice "two" Nothing 2, Choice "minus 1" Nothing (-1)])
+ (Just $ -1)
+ (Just $ -2),
+ OptionValueInteger
+ "numbercomm3"
+ Nothing
+ "another another number option"
+ Nothing
+ False
+ (Left True)
+ (Just $ -50)
+ (Just 50),
+ OptionValueUser
+ "user"
+ Nothing
+ "testing asking for a user"
+ Nothing
+ False,
+ OptionValueChannel
+ "channel"
+ Nothing
+ "testing asking for a channel"
+ Nothing
+ False
+ (Just [ChannelTypeOptionGuildVoice]),
+ OptionValueMentionable
+ "mentionable"
+ Nothing
+ "testing asking for a mentionable"
+ Nothing
+ False
+ ]
+ ]
+ )
+ }
+
+-- | An example slash command.
+exampleSlashCommand :: Maybe CreateApplicationCommand
+exampleSlashCommand =
+ createChatInput
+ "test"
+ "here is a description"
+ >>= \cac ->
+ return $
+ cac
+ { createOptions =
+ Just $
+ OptionsValues
+ [ OptionValueString
+ "randominput"
+ Nothing
+ "I shall not"
+ Nothing
+ True
+ (Right [Choice "firstOpt" Nothing "yay", Choice "secondOpt" Nothing "nay"])
+ Nothing
+ Nothing
+ ]
+ }
+
+exampleInteractionResponse :: OptionsData -> InteractionResponse
+exampleInteractionResponse (OptionsDataValues [OptionDataValueString {optionDataValueString = s}]) =
+ interactionResponseBasic (T.pack $ "Here's the reply! You chose: " ++ show s)
+exampleInteractionResponse _ =
+ interactionResponseBasic
+ "Something unexpected happened - the value was not what I expected!"
+
+getImage :: IO B.ByteString
+getImage = return "\137PNG\r\n\SUB\n\NUL\NUL\NUL\rIHDR\NUL\NUL\NUL\SOH\NUL\NUL\NUL\SOH\b\STX\NUL\NUL\NUL\144wS\222\NUL\NUL\NUL\SOHsRGB\NUL\174\206\FS\233\NUL\NUL\NUL\EOTgAMA\NUL\NUL\177\143\v\252a\ENQ\NUL\NUL\NUL\tpHYs\NUL\NUL\SO\195\NUL\NUL\SO\195\SOH\199o\168d\NUL\NUL\NUL\fIDAT\CANWc\248\239\180\t\NUL\EOT7\SOH\244\162\155\ENQ\235\NUL\NUL\NUL\NULIEND\174B`\130"
+
+
+-- If an event handler throws an exception, discord-haskell will continue to run
+eventHandler :: GuildId -> Event -> DiscordHandler ()
+eventHandler testserverid event = case event of
+ MessageCreate m -> when (not (fromBot m) && isPing m) $ do
+ void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes")
+ threadDelay (2 * 10 ^ (6 :: Int))
+
+ -- A very simple message.
+ void $ restCall (R.CreateMessage (messageChannelId m) "Pong!")
+ exampleImage <- liftIO getImage
+
+ -- A more complex message. Text-to-speech, does not mention everyone nor
+ -- the user, and uses Discord native replies.
+ -- Use ":info" in ghci to explore the type
+ let opts :: R.MessageDetailedOpts
+ opts =
+ def
+ { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!",
+ R.messageDetailedTTS = True,
+ R.messageDetailedAllowedMentions =
+ Just $
+ def
+ { R.mentionEveryone = False,
+ R.mentionRepliedUser = False
+ },
+ R.messageDetailedReference =
+ Just $
+ def {referenceMessageId = Just $ messageId m}
+ }
+ void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts)
+ let opts' :: R.MessageDetailedOpts
+ opts' =
+ def
+ { R.messageDetailedContent = "An example of a message with buttons!",
+ R.messageDetailedComponents =
+ Just
+ [ ActionRowButtons
+ [ Button "Button 1" False ButtonStylePrimary (Just "Button 1") (Just (mkEmoji "🔥")),
+ Button "Button 2" True ButtonStyleSuccess (Just "Button 2") Nothing,
+ ButtonUrl
+ "https://github.com/discord-haskell/discord-haskell"
+ False
+ (Just "Button 3")
+ Nothing
+ ],
+ ActionRowSelectMenu
+ ( SelectMenu
+ "action select menu"
+ False
+ (SelectMenuDataText [ SelectOption "First option" "opt1" (Just "the only desc") Nothing Nothing,
+ SelectOption "Second option" "opt2" Nothing (Just (mkEmoji "😭")) (Just True),
+ SelectOption "third option" "opt3" Nothing Nothing Nothing,
+ SelectOption "fourth option" "opt4" Nothing Nothing Nothing,
+ SelectOption "fifth option" "opt5" Nothing Nothing Nothing
+ ])
+ (Just "this is a place holder")
+ (Just 2)
+ (Just 5)
+ ),
+ ActionRowSelectMenu
+ ( SelectMenu
+ "user select menu"
+ False
+ (SelectMenuDataUser)
+ (Just "this is a place holder")
+ (Just 3)
+ (Just 3)
+ ),
+ ActionRowSelectMenu
+ ( SelectMenu
+ "channel select menu"
+ False
+ (SelectMenuDataChannels [ChannelTypeOptionGuildText,ChannelTypeOptionGuildPublicThread,ChannelTypeOptionGuildCategory])
+ (Just "this is a place holder")
+ (Just 1)
+ (Just 1)
+ )
+ ],
+ R.messageDetailedEmbeds =
+ Just
+ [ def
+ { createEmbedTitle = "Title",
+ createEmbedDescription = "the description",
+ createEmbedAuthorName = "Author name is Required",
+ createEmbedImage = Just (CreateEmbedImageUrl "https://media.discordapp.net/attachments/365969021083975681/936055590415921172/Warning.png"),
+ createEmbedColor = Just DiscordColorLuminousVividPink,
+ createEmbedAuthorIcon = Just (CreateEmbedImageUpload exampleImage)
+ },
+ def {createEmbedTitle = "a different Title", createEmbedDescription = "another desc"}
+ ]
+ }
+ tictactoe :: R.MessageDetailedOpts
+ tictactoe =
+ def
+ { R.messageDetailedContent = "Playing tic tac toe! Player 0",
+ R.messageDetailedComponents = Just $ updateTicTacToe Nothing []
+ }
+ void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts')
+ void $ restCall (R.CreateMessageDetailed (messageChannelId m) tictactoe)
+ Ready _ _ _ _ _ _ (PartialApplication i _) -> do
+ vs <-
+ mapM
+ (maybe (return (Left $ RestCallErrorCode 0 "" "")) (restCall . R.CreateGuildApplicationCommand i testserverid))
+ [exampleSlashCommand, exampleUserCommand, newExampleSlashCommand, createChatInput "modal" "modal test"]
+ liftIO (putStrLn $ "number of application commands added " ++ show (length vs))
+ acs <- restCall (R.GetGuildApplicationCommands i testserverid)
+ case acs of
+ Left r -> liftIO $ print r
+ Right ls -> liftIO $ putStrLn $ "number of application commands total " ++ show (length ls)
+ InteractionCreate InteractionComponent {componentData = cb@ButtonData {componentDataCustomId = (T.take 3 -> "ttt")}, ..} -> case processTicTacToe cb interactionMessage of
+ [r] ->
+ void
+ ( restCall
+ ( R.CreateInteractionResponse
+ interactionId
+ interactionToken
+ (InteractionResponseUpdateMessage r)
+ )
+ )
+ r : rs ->
+ void
+ ( restCall $
+ R.CreateInteractionResponse
+ interactionId
+ interactionToken
+ (InteractionResponseUpdateMessage r)
+ )
+ >> mapM_
+ ( restCall
+ . R.CreateFollowupInteractionMessage
+ interactionApplicationId
+ interactionToken
+ )
+ rs
+ _ -> return ()
+ InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataUser {applicationCommandDataName = nm, applicationCommandDataTargetUserId = uid, ..}, ..} ->
+ void $
+ restCall
+ (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic $ "Command " <> nm <> T.pack (" selected user: " ++ show uid)))
+ InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "test", optionsData = Just d, ..}, ..} ->
+ void $
+ restCall
+ (R.CreateInteractionResponse interactionId interactionToken (exampleInteractionResponse d))
+ InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "subtest", optionsData = Just d, ..}, ..} -> void $ restCall (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic (T.pack $ "oh boy, subcommands! welp, here's everything I got from that: " <> show d)))
+ InteractionCreate InteractionComponent {componentData = ButtonData {..}, ..} ->
+ void $
+ restCall
+ ( R.CreateInteractionResponse interactionId interactionToken $
+ InteractionResponseChannelMessage
+ ( ( interactionResponseMessageBasic $ "You pressed the button " <> componentDataCustomId
+ )
+ { interactionResponseMessageFlags = Just (InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral])
+ }
+ )
+ )
+ InteractionCreate InteractionComponent {componentData = SelectMenuData {componentDataValues = vs}, ..} ->
+ void
+ ( do
+ exampleImage <- liftIO getImage
+ aid <- readCache <&> cacheApplication <&> partialApplicationID
+ _ <- restCall (R.CreateInteractionResponse interactionId interactionToken InteractionResponseDeferChannelMessage)
+ restCall
+ ( R.CreateFollowupInteractionMessage
+ aid
+ interactionToken
+ (interactionResponseMessageBasic (T.pack $ "oh dear, select menu. thank you for waiting" <> show vs))
+ { interactionResponseMessageEmbeds =
+ Just
+ [ def
+ { createEmbedTitle = "Select menu title",
+ createEmbedDescription = "Here is the select menu embed desc",
+ createEmbedAuthorName = "someunknownentity",
+ createEmbedImage = Just (CreateEmbedImageUrl "https://media.discordapp.net/attachments/365969021083975681/936055590415921172/Warning.png"),
+ createEmbedColor = Just DiscordColorDiscordBlurple,
+ createEmbedAuthorIcon = Just (CreateEmbedImageUpload exampleImage)
+ }
+ ]
+ }
+ )
+ )
+ InteractionCreate InteractionApplicationCommandAutocomplete {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "subtest", optionsData = Just _, ..}, ..} -> void (restCall $ R.CreateInteractionResponse interactionId interactionToken (InteractionResponseAutocompleteResult (InteractionResponseAutocompleteInteger [Choice "five" Nothing 5])))
+ InteractionCreate i@InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "modal"}} ->
+ void $
+ restCall
+ ( R.CreateInteractionResponse
+ (interactionId i)
+ (interactionToken i)
+ ( InteractionResponseModal
+ ( InteractionResponseModalData
+ "customidmodal"
+ "modal title"
+ [mkTextInput "textcid" "textlabel"]
+ )
+ )
+ )
+ InteractionCreate i@InteractionModalSubmit {modalData = idm} -> void $ restCall (R.CreateInteractionResponse (interactionId i) (interactionToken i) (interactionResponseBasic (T.pack (show idm))))
+ _ -> return ()
+
+processTicTacToe :: ComponentData -> Message -> [InteractionResponseMessage]
+processTicTacToe (ButtonData cid) m = case messageComponents m of
+ Nothing -> [interactionResponseMessageBasic "Sorry, I couldn't get the components on that message."]
+ (Just cs) ->
+ let newComp = newComp' cs
+ in ( ( interactionResponseMessageBasic
+ ("Some Tic Tac Toe! Player " <> (if '0' == T.last (messageContent m) then "1" else "0"))
+ )
+ { interactionResponseMessageComponents = Just ((if checkTicTacToe newComp then (disableAll <$>) else id) newComp)
+ }
+ ) :
+ [interactionResponseMessageBasic ("Player " <> T.singleton player <> " has won!") | checkTicTacToe newComp]
+ where
+ player = T.last (messageContent m)
+ newComp' = updateTicTacToe (Just (cid, '0' == player))
+ disableAll (ActionRowButtons cs) = ActionRowButtons $ (\c -> c {buttonDisabled = True}) <$> cs
+ disableAll c = c
+processTicTacToe _ _ = [interactionResponseMessageBasic "Sorry, I couldn't understand that button."]
+
+checkTicTacToe :: [ActionRow] -> Bool
+checkTicTacToe xs = checkRows unwrapped || checkRows unwrappedT || checkRows [diagonal unwrapped, diagonal (reverse <$> unwrapped)]
+ where
+ checkRows = any (\cbs -> all (\cb -> cb == head cbs && cb /= ButtonStyleSecondary) cbs)
+ unwrapped = (\(ActionRowButtons cbs) -> (\Button {buttonStyle = style} -> style) <$> cbs) <$> xs
+ unwrappedT = transpose unwrapped
+ diagonal [] = []
+ diagonal ([] : _) = []
+ diagonal (ys : yss) = head ys : diagonal (tail <$> yss)
+
+updateTicTacToe :: Maybe (T.Text, Bool) -> [ActionRow] -> [ActionRow]
+updateTicTacToe Nothing _ = (\y -> ActionRowButtons $ (\x -> Button (T.pack $ "ttt " <> show x <> show y) False ButtonStyleSecondary (Just "[ ]") Nothing) <$> [0 .. 4]) <$> [0 .. 4]
+updateTicTacToe (Just (tttxy, isFirst)) car
+ | not (checkIsValid tttxy) = car
+ | otherwise = (\(ActionRowButtons cbs) -> ActionRowButtons (changeIf <$> cbs)) <$> car
+ where
+ checkIsValid tttxy' = T.length tttxy' == 6 && all isDigit [T.index tttxy' 4, T.index tttxy' 5]
+ getxy tttxy' = (T.index tttxy' 4, T.index tttxy' 5)
+ (style, symbol) = if isFirst then (ButtonStyleSuccess, "[X]") else (ButtonStyleDanger, "[O]")
+ changeIf cb@Button {..}
+ | checkIsValid buttonCustomId && getxy tttxy == getxy buttonCustomId = cb {buttonDisabled = True, buttonStyle = style, buttonLabel = Just symbol}
+ | otherwise = cb
+ changeIf cb = cb
+
+fromBot :: Message -> Bool
+fromBot = userIsBot . messageAuthor
+
+isPing :: Message -> Bool
+isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 11:05:26 +0000