From dcef0b65069fb38fd0f6c4382353167f603ebff1 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Thu, 16 Nov 2023 19:06:43 -0500 Subject: Initial commit --- deps/discord-haskell/examples/ExampleUtils.hs | 29 ++ deps/discord-haskell/examples/cache.hs | 27 ++ deps/discord-haskell/examples/embed-photo.jpg | Bin 0 -> 41922 bytes deps/discord-haskell/examples/example-setup | 7 + deps/discord-haskell/examples/gateway.hs | 53 +++ .../examples/interaction-commands-simple.hs | 125 ++++++ .../examples/interaction-commands.hs | 483 +++++++++++++++++++++ deps/discord-haskell/examples/ping-pong.hs | 97 +++++ .../examples/rest-without-gateway.hs | 50 +++ deps/discord-haskell/examples/state-counter.hs | 75 ++++ 10 files changed, 946 insertions(+) create mode 100644 deps/discord-haskell/examples/ExampleUtils.hs create mode 100644 deps/discord-haskell/examples/cache.hs create mode 100644 deps/discord-haskell/examples/embed-photo.jpg create mode 100644 deps/discord-haskell/examples/example-setup create mode 100644 deps/discord-haskell/examples/gateway.hs create mode 100644 deps/discord-haskell/examples/interaction-commands-simple.hs create mode 100644 deps/discord-haskell/examples/interaction-commands.hs create mode 100644 deps/discord-haskell/examples/ping-pong.hs create mode 100644 deps/discord-haskell/examples/rest-without-gateway.hs create mode 100644 deps/discord-haskell/examples/state-counter.hs (limited to 'deps/discord-haskell/examples') diff --git a/deps/discord-haskell/examples/ExampleUtils.hs b/deps/discord-haskell/examples/ExampleUtils.hs new file mode 100644 index 0000000..517178b --- /dev/null +++ b/deps/discord-haskell/examples/ExampleUtils.hs @@ -0,0 +1,29 @@ +module ExampleUtils where + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Discord +import qualified Discord.Requests as R +import Discord.Types +import Text.Read (readMaybe) + +getToken :: IO T.Text +getToken = TIO.readFile "./examples/auth-token.secret" + +getGuildId :: IO GuildId +getGuildId = do + gids <- readFile "./examples/guildid.secret" + case readMaybe gids of + Just g -> pure g + Nothing -> error "could not read guild id from `guildid.secret`" + +-- | Given the test server and an action operating on a channel id, get the +-- first text channel of that server and use the action on that channel. +actionWithChannelId :: GuildId -> (ChannelId -> DiscordHandler a) -> DiscordHandler a +actionWithChannelId testserverid f = do + Right chans <- restCall $ R.GetGuildChannels testserverid + (f . channelId) (head (filter isTextChannel chans)) + where + isTextChannel :: Channel -> Bool + isTextChannel ChannelText {} = True + isTextChannel _ = False diff --git a/deps/discord-haskell/examples/cache.hs b/deps/discord-haskell/examples/cache.hs new file mode 100644 index 0000000..2e26f53 --- /dev/null +++ b/deps/discord-haskell/examples/cache.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +import UnliftIO (liftIO) + +import Discord + +import ExampleUtils (getToken) + +main :: IO () +main = cacheExample + +-- There's not much information in the Cache for now +-- but this program will show you what its got + +-- | Print cached Gateway info +cacheExample :: IO () +cacheExample = do + tok <- getToken + + _ <- runDiscord $ def { discordToken = tok + , discordOnStart = do + cache <- readCache + liftIO $ putStrLn ("Cached info from gateway: " <> show cache) + stopDiscord + } + pure () + diff --git a/deps/discord-haskell/examples/embed-photo.jpg b/deps/discord-haskell/examples/embed-photo.jpg new file mode 100644 index 0000000..99d7199 Binary files /dev/null and b/deps/discord-haskell/examples/embed-photo.jpg differ diff --git a/deps/discord-haskell/examples/example-setup b/deps/discord-haskell/examples/example-setup new file mode 100644 index 0000000..51458cc --- /dev/null +++ b/deps/discord-haskell/examples/example-setup @@ -0,0 +1,7 @@ +create a file named auth-token.secret and add your token (not the secret id) from +https://discord.com/developers/applications/me + +This is the Bot token (NOT CLIENT SECRET) from developer portal under the settings tab + +create a file named guildid.secret and add the guild id (server id) of your test server there. +your bot may need certain permissions to run specific examples, like the interaction-commands example. diff --git a/deps/discord-haskell/examples/gateway.hs b/deps/discord-haskell/examples/gateway.hs new file mode 100644 index 0000000..57e2e75 --- /dev/null +++ b/deps/discord-haskell/examples/gateway.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (forever) +import Control.Concurrent (forkIO, killThread) +import UnliftIO (liftIO) +import Control.Concurrent.Chan +import qualified Data.Text.IO as TIO + +import Discord +import Discord.Types + +import ExampleUtils (getToken, getGuildId) + +main :: IO () +main = gatewayExample + +-- | Prints every event as it happens +gatewayExample :: IO () +gatewayExample = do + tok <- getToken + testserverid <- getGuildId + + outChan <- newChan :: IO (Chan String) + + -- Events are processed in new threads, but stdout isn't + -- synchronized. We get ugly output when multiple threads + -- write to stdout at the same time + threadId <- forkIO $ forever $ readChan outChan >>= putStrLn + + err <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler testserverid + , discordOnEvent = eventHandler outChan + , discordOnEnd = killThread threadId + } + TIO.putStrLn err + +-- Events are enumerated in the discord docs +-- https://discord.com/developers/docs/topics/gateway#commands-and-events-gateway-events +eventHandler :: Chan String -> Event -> DiscordHandler () +eventHandler out event = liftIO $ writeChan out (show event <> "\n") + + +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do + let opts = RequestGuildMembersOpts + { requestGuildMembersOptsGuildId = testserverid + , requestGuildMembersOptsLimit = 100 + , requestGuildMembersOptsNamesStartingWith = "" + } + + -- gateway commands are enumerated in the discord docs + -- https://discord.com/developers/docs/topics/gateway#commands-and-events-gateway-commands + sendCommand (RequestGuildMembers opts) diff --git a/deps/discord-haskell/examples/interaction-commands-simple.hs b/deps/discord-haskell/examples/interaction-commands-simple.hs new file mode 100644 index 0000000..bf46321 --- /dev/null +++ b/deps/discord-haskell/examples/interaction-commands-simple.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Discord +import Discord.Types +import Discord.Interactions +import UnliftIO (liftIO) +import Data.List (find) +import Control.Monad (forM_) +import ExampleUtils (getToken, getGuildId) +import Data.Text (Text) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import qualified Discord.Requests as R +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + + +-- MAIN + +main :: IO () +main = do + tok <- getToken + testGuildId <- getGuildId + + botTerminationError <- runDiscord $ def + { discordToken = tok + , discordOnEvent = onDiscordEvent testGuildId + -- If you are using application commands, you might not need + -- message contents at all + , discordGatewayIntent = def { gatewayIntentMessageContent = False } + } + + echo $ "A fatal error occurred: " <> botTerminationError + + +-- UTILS + +echo :: MonadIO m => Text -> m () +echo = liftIO . TIO.putStrLn + +showT :: Show a => a -> Text +showT = T.pack . show + + +-- COMMANDS + +data SlashCommand = SlashCommand + { name :: Text + , registration :: Maybe CreateApplicationCommand + , handler :: Interaction -> Maybe OptionsData -> DiscordHandler () + } + +mySlashCommands :: [SlashCommand] +mySlashCommands = [ping] + +ping :: SlashCommand +ping = SlashCommand + { name = "ping" + , registration = createChatInput "ping" "responds pong" + , handler = \intr _options -> + void . restCall $ + R.CreateInteractionResponse + (interactionId intr) + (interactionToken intr) + (interactionResponseBasic "pong") + } + + +-- EVENTS + +onDiscordEvent :: GuildId -> Event -> DiscordHandler () +onDiscordEvent testGuildId = \case + Ready _ _ _ _ _ _ (PartialApplication appId _) -> onReady appId testGuildId + InteractionCreate intr -> onInteractionCreate intr + _ -> pure () + +onReady :: ApplicationId -> GuildId -> DiscordHandler () +onReady appId testGuildId = do + echo "Bot ready!" + + appCmdRegistrations <- mapM tryRegistering mySlashCommands + + case sequence appCmdRegistrations of + Left err -> + echo $ "[!] Failed to register some commands" <> showT err + + Right cmds -> do + echo $ "Registered " <> showT (length cmds) <> " command(s)." + unregisterOutdatedCmds cmds + + where + tryRegistering cmd = case registration cmd of + Just reg -> restCall $ R.CreateGuildApplicationCommand appId testGuildId reg + Nothing -> pure . Left $ RestCallErrorCode 0 "" "" + + unregisterOutdatedCmds validCmds = do + registered <- restCall $ R.GetGuildApplicationCommands appId testGuildId + case registered of + Left err -> + echo $ "Failed to get registered slash commands: " <> showT err + + Right cmds -> + let validIds = map applicationCommandId validCmds + outdatedIds = filter (`notElem` validIds) + . map applicationCommandId + $ cmds + in forM_ outdatedIds $ + restCall . R.DeleteGuildApplicationCommand appId testGuildId + +onInteractionCreate :: Interaction -> DiscordHandler () +onInteractionCreate = \case + cmd@InteractionApplicationCommand + { applicationCommandData = input@ApplicationCommandDataChatInput {} } -> + case + find (\c -> applicationCommandDataName input == name c) mySlashCommands + of + Just found -> + handler found cmd (optionsData input) + + Nothing -> + echo "Somehow got unknown slash command (registrations out of date?)" + + _ -> + pure () -- Unexpected/unsupported interaction type diff --git a/deps/discord-haskell/examples/interaction-commands.hs b/deps/discord-haskell/examples/interaction-commands.hs new file mode 100644 index 0000000..7d22825 --- /dev/null +++ b/deps/discord-haskell/examples/interaction-commands.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +import Control.Monad (when) +import qualified Data.ByteString as B +import Data.Char (isDigit) +import Data.Functor ((<&>)) +import Data.List (transpose) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Discord +import Discord.Interactions +import qualified Discord.Requests as R +import Discord.Types +import UnliftIO (liftIO) +import UnliftIO.Concurrent + +import ExampleUtils (getToken, getGuildId, actionWithChannelId) + +main :: IO () +main = interactionCommandExample + +void :: DiscordHandler (Either RestCallErrorCode b) -> DiscordHandler () +void = + ( >>= + ( \case + Left e -> liftIO $ print e + Right _ -> return () + ) + ) + +-- | Creates and manages a variety of interactions, including a tic tac toe example. +interactionCommandExample :: IO () +interactionCommandExample = do + tok <- getToken + testserverid <- getGuildId + + -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields + t <- + runDiscord $ + def + { discordToken = tok, + discordOnStart = startHandler testserverid, + discordOnEnd = liftIO $ putStrLn "Ended", + discordOnEvent = eventHandler testserverid, + discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "", + discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPresences = True} + } + TIO.putStrLn t + +-- If the start handler throws an exception, discord-haskell will gracefully shutdown +-- Use place to execute commands you know you want to complete +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do + let activity = + def + { activityName = "ping-pong", + activityType = ActivityTypeGame + } + let opts = + UpdateStatusOpts + { updateStatusOptsSince = Nothing, + updateStatusOptsGame = Just activity, + updateStatusOptsNewStatus = UpdateStatusOnline, + updateStatusOptsAFK = False + } + sendCommand (UpdateStatus opts) + + actionWithChannelId testserverid $ \cid -> + void $ + restCall $ + R.CreateMessage + cid + "Hello! I will reply to pings with pongs" + +-- | Example user command +exampleUserCommand :: Maybe CreateApplicationCommand +exampleUserCommand = createUser "usercomm" + +-- | Example slash command that has subcommands and multiple types of fields. +newExampleSlashCommand :: Maybe CreateApplicationCommand +newExampleSlashCommand = + createChatInput + "subtest" + "testing out subcommands" + >>= \d -> + Just $ + d + { createOptions = + Just + ( OptionsSubcommands + [ OptionSubcommandGroup + "frstsubcmdgrp" + Nothing + "the sub command group" + Nothing + [ OptionSubcommand + "frstsubcmd" + Nothing + "the first sub sub command" + Nothing + [ OptionValueString + "onestringinput" + Nothing + "two options" + Nothing + True + ( Right + [ Choice "green" Nothing "green", + Choice "red" Nothing "red" + ] + ) + Nothing + Nothing, + OptionValueInteger "oneintinput" Nothing "choices galore" Nothing False (Left False) Nothing Nothing + ] + ], + OptionSubcommandOrGroupSubcommand $ + OptionSubcommand + "frstsubcmd" + Nothing + "the first subcommand" + Nothing + [ OptionValueString + "onestringinput" + Nothing + "two options" + Nothing + True + ( Right + [ Choice "yellow" Nothing "yellow", + Choice "blue" Nothing "blue" + ] + ) + Nothing + Nothing + ], + OptionSubcommandOrGroupSubcommand $ + OptionSubcommand + "sndsubcmd" + Nothing + "the second subcommand" + Nothing + [ OptionValueBoolean + "trueorfalse" + Nothing + "true or false" + Nothing + True, + OptionValueNumber + "numbercomm" + Nothing + "number option" + Nothing + False + (Left True) + (Just 3.1415) + (Just 101), + OptionValueInteger + "numbercomm2" + Nothing + "another number option" + Nothing + False + (Right [Choice "one" Nothing 1, Choice "two" Nothing 2, Choice "minus 1" Nothing (-1)]) + (Just $ -1) + (Just $ -2), + OptionValueInteger + "numbercomm3" + Nothing + "another another number option" + Nothing + False + (Left True) + (Just $ -50) + (Just 50), + OptionValueUser + "user" + Nothing + "testing asking for a user" + Nothing + False, + OptionValueChannel + "channel" + Nothing + "testing asking for a channel" + Nothing + False + (Just [ChannelTypeOptionGuildVoice]), + OptionValueMentionable + "mentionable" + Nothing + "testing asking for a mentionable" + Nothing + False + ] + ] + ) + } + +-- | An example slash command. +exampleSlashCommand :: Maybe CreateApplicationCommand +exampleSlashCommand = + createChatInput + "test" + "here is a description" + >>= \cac -> + return $ + cac + { createOptions = + Just $ + OptionsValues + [ OptionValueString + "randominput" + Nothing + "I shall not" + Nothing + True + (Right [Choice "firstOpt" Nothing "yay", Choice "secondOpt" Nothing "nay"]) + Nothing + Nothing + ] + } + +exampleInteractionResponse :: OptionsData -> InteractionResponse +exampleInteractionResponse (OptionsDataValues [OptionDataValueString {optionDataValueString = s}]) = + interactionResponseBasic (T.pack $ "Here's the reply! You chose: " ++ show s) +exampleInteractionResponse _ = + interactionResponseBasic + "Something unexpected happened - the value was not what I expected!" + +getImage :: IO B.ByteString +getImage = return "\137PNG\r\n\SUB\n\NUL\NUL\NUL\rIHDR\NUL\NUL\NUL\SOH\NUL\NUL\NUL\SOH\b\STX\NUL\NUL\NUL\144wS\222\NUL\NUL\NUL\SOHsRGB\NUL\174\206\FS\233\NUL\NUL\NUL\EOTgAMA\NUL\NUL\177\143\v\252a\ENQ\NUL\NUL\NUL\tpHYs\NUL\NUL\SO\195\NUL\NUL\SO\195\SOH\199o\168d\NUL\NUL\NUL\fIDAT\CANWc\248\239\180\t\NUL\EOT7\SOH\244\162\155\ENQ\235\NUL\NUL\NUL\NULIEND\174B`\130" + + +-- If an event handler throws an exception, discord-haskell will continue to run +eventHandler :: GuildId -> Event -> DiscordHandler () +eventHandler testserverid event = case event of + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") + threadDelay (2 * 10 ^ (6 :: Int)) + + -- A very simple message. + void $ restCall (R.CreateMessage (messageChannelId m) "Pong!") + exampleImage <- liftIO getImage + + -- A more complex message. Text-to-speech, does not mention everyone nor + -- the user, and uses Discord native replies. + -- Use ":info" in ghci to explore the type + let opts :: R.MessageDetailedOpts + opts = + def + { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!", + R.messageDetailedTTS = True, + R.messageDetailedAllowedMentions = + Just $ + def + { R.mentionEveryone = False, + R.mentionRepliedUser = False + }, + R.messageDetailedReference = + Just $ + def {referenceMessageId = Just $ messageId m} + } + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts) + let opts' :: R.MessageDetailedOpts + opts' = + def + { R.messageDetailedContent = "An example of a message with buttons!", + R.messageDetailedComponents = + Just + [ ActionRowButtons + [ Button "Button 1" False ButtonStylePrimary (Just "Button 1") (Just (mkEmoji "🔥")), + Button "Button 2" True ButtonStyleSuccess (Just "Button 2") Nothing, + ButtonUrl + "https://github.com/discord-haskell/discord-haskell" + False + (Just "Button 3") + Nothing + ], + ActionRowSelectMenu + ( SelectMenu + "action select menu" + False + (SelectMenuDataText [ SelectOption "First option" "opt1" (Just "the only desc") Nothing Nothing, + SelectOption "Second option" "opt2" Nothing (Just (mkEmoji "😭")) (Just True), + SelectOption "third option" "opt3" Nothing Nothing Nothing, + SelectOption "fourth option" "opt4" Nothing Nothing Nothing, + SelectOption "fifth option" "opt5" Nothing Nothing Nothing + ]) + (Just "this is a place holder") + (Just 2) + (Just 5) + ), + ActionRowSelectMenu + ( SelectMenu + "user select menu" + False + (SelectMenuDataUser) + (Just "this is a place holder") + (Just 3) + (Just 3) + ), + ActionRowSelectMenu + ( SelectMenu + "channel select menu" + False + (SelectMenuDataChannels [ChannelTypeOptionGuildText,ChannelTypeOptionGuildPublicThread,ChannelTypeOptionGuildCategory]) + (Just "this is a place holder") + (Just 1) + (Just 1) + ) + ], + R.messageDetailedEmbeds = + Just + [ def + { createEmbedTitle = "Title", + createEmbedDescription = "the description", + createEmbedAuthorName = "Author name is Required", + createEmbedImage = Just (CreateEmbedImageUrl "https://media.discordapp.net/attachments/365969021083975681/936055590415921172/Warning.png"), + createEmbedColor = Just DiscordColorLuminousVividPink, + createEmbedAuthorIcon = Just (CreateEmbedImageUpload exampleImage) + }, + def {createEmbedTitle = "a different Title", createEmbedDescription = "another desc"} + ] + } + tictactoe :: R.MessageDetailedOpts + tictactoe = + def + { R.messageDetailedContent = "Playing tic tac toe! Player 0", + R.messageDetailedComponents = Just $ updateTicTacToe Nothing [] + } + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts') + void $ restCall (R.CreateMessageDetailed (messageChannelId m) tictactoe) + Ready _ _ _ _ _ _ (PartialApplication i _) -> do + vs <- + mapM + (maybe (return (Left $ RestCallErrorCode 0 "" "")) (restCall . R.CreateGuildApplicationCommand i testserverid)) + [exampleSlashCommand, exampleUserCommand, newExampleSlashCommand, createChatInput "modal" "modal test"] + liftIO (putStrLn $ "number of application commands added " ++ show (length vs)) + acs <- restCall (R.GetGuildApplicationCommands i testserverid) + case acs of + Left r -> liftIO $ print r + Right ls -> liftIO $ putStrLn $ "number of application commands total " ++ show (length ls) + InteractionCreate InteractionComponent {componentData = cb@ButtonData {componentDataCustomId = (T.take 3 -> "ttt")}, ..} -> case processTicTacToe cb interactionMessage of + [r] -> + void + ( restCall + ( R.CreateInteractionResponse + interactionId + interactionToken + (InteractionResponseUpdateMessage r) + ) + ) + r : rs -> + void + ( restCall $ + R.CreateInteractionResponse + interactionId + interactionToken + (InteractionResponseUpdateMessage r) + ) + >> mapM_ + ( restCall + . R.CreateFollowupInteractionMessage + interactionApplicationId + interactionToken + ) + rs + _ -> return () + InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataUser {applicationCommandDataName = nm, applicationCommandDataTargetUserId = uid, ..}, ..} -> + void $ + restCall + (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic $ "Command " <> nm <> T.pack (" selected user: " ++ show uid))) + InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "test", optionsData = Just d, ..}, ..} -> + void $ + restCall + (R.CreateInteractionResponse interactionId interactionToken (exampleInteractionResponse d)) + InteractionCreate InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "subtest", optionsData = Just d, ..}, ..} -> void $ restCall (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic (T.pack $ "oh boy, subcommands! welp, here's everything I got from that: " <> show d))) + InteractionCreate InteractionComponent {componentData = ButtonData {..}, ..} -> + void $ + restCall + ( R.CreateInteractionResponse interactionId interactionToken $ + InteractionResponseChannelMessage + ( ( interactionResponseMessageBasic $ "You pressed the button " <> componentDataCustomId + ) + { interactionResponseMessageFlags = Just (InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]) + } + ) + ) + InteractionCreate InteractionComponent {componentData = SelectMenuData {componentDataValues = vs}, ..} -> + void + ( do + exampleImage <- liftIO getImage + aid <- readCache <&> cacheApplication <&> partialApplicationID + _ <- restCall (R.CreateInteractionResponse interactionId interactionToken InteractionResponseDeferChannelMessage) + restCall + ( R.CreateFollowupInteractionMessage + aid + interactionToken + (interactionResponseMessageBasic (T.pack $ "oh dear, select menu. thank you for waiting" <> show vs)) + { interactionResponseMessageEmbeds = + Just + [ def + { createEmbedTitle = "Select menu title", + createEmbedDescription = "Here is the select menu embed desc", + createEmbedAuthorName = "someunknownentity", + createEmbedImage = Just (CreateEmbedImageUrl "https://media.discordapp.net/attachments/365969021083975681/936055590415921172/Warning.png"), + createEmbedColor = Just DiscordColorDiscordBlurple, + createEmbedAuthorIcon = Just (CreateEmbedImageUpload exampleImage) + } + ] + } + ) + ) + InteractionCreate InteractionApplicationCommandAutocomplete {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "subtest", optionsData = Just _, ..}, ..} -> void (restCall $ R.CreateInteractionResponse interactionId interactionToken (InteractionResponseAutocompleteResult (InteractionResponseAutocompleteInteger [Choice "five" Nothing 5]))) + InteractionCreate i@InteractionApplicationCommand {applicationCommandData = ApplicationCommandDataChatInput {applicationCommandDataName = "modal"}} -> + void $ + restCall + ( R.CreateInteractionResponse + (interactionId i) + (interactionToken i) + ( InteractionResponseModal + ( InteractionResponseModalData + "customidmodal" + "modal title" + [mkTextInput "textcid" "textlabel"] + ) + ) + ) + InteractionCreate i@InteractionModalSubmit {modalData = idm} -> void $ restCall (R.CreateInteractionResponse (interactionId i) (interactionToken i) (interactionResponseBasic (T.pack (show idm)))) + _ -> return () + +processTicTacToe :: ComponentData -> Message -> [InteractionResponseMessage] +processTicTacToe (ButtonData cid) m = case messageComponents m of + Nothing -> [interactionResponseMessageBasic "Sorry, I couldn't get the components on that message."] + (Just cs) -> + let newComp = newComp' cs + in ( ( interactionResponseMessageBasic + ("Some Tic Tac Toe! Player " <> (if '0' == T.last (messageContent m) then "1" else "0")) + ) + { interactionResponseMessageComponents = Just ((if checkTicTacToe newComp then (disableAll <$>) else id) newComp) + } + ) : + [interactionResponseMessageBasic ("Player " <> T.singleton player <> " has won!") | checkTicTacToe newComp] + where + player = T.last (messageContent m) + newComp' = updateTicTacToe (Just (cid, '0' == player)) + disableAll (ActionRowButtons cs) = ActionRowButtons $ (\c -> c {buttonDisabled = True}) <$> cs + disableAll c = c +processTicTacToe _ _ = [interactionResponseMessageBasic "Sorry, I couldn't understand that button."] + +checkTicTacToe :: [ActionRow] -> Bool +checkTicTacToe xs = checkRows unwrapped || checkRows unwrappedT || checkRows [diagonal unwrapped, diagonal (reverse <$> unwrapped)] + where + checkRows = any (\cbs -> all (\cb -> cb == head cbs && cb /= ButtonStyleSecondary) cbs) + unwrapped = (\(ActionRowButtons cbs) -> (\Button {buttonStyle = style} -> style) <$> cbs) <$> xs + unwrappedT = transpose unwrapped + diagonal [] = [] + diagonal ([] : _) = [] + diagonal (ys : yss) = head ys : diagonal (tail <$> yss) + +updateTicTacToe :: Maybe (T.Text, Bool) -> [ActionRow] -> [ActionRow] +updateTicTacToe Nothing _ = (\y -> ActionRowButtons $ (\x -> Button (T.pack $ "ttt " <> show x <> show y) False ButtonStyleSecondary (Just "[ ]") Nothing) <$> [0 .. 4]) <$> [0 .. 4] +updateTicTacToe (Just (tttxy, isFirst)) car + | not (checkIsValid tttxy) = car + | otherwise = (\(ActionRowButtons cbs) -> ActionRowButtons (changeIf <$> cbs)) <$> car + where + checkIsValid tttxy' = T.length tttxy' == 6 && all isDigit [T.index tttxy' 4, T.index tttxy' 5] + getxy tttxy' = (T.index tttxy' 4, T.index tttxy' 5) + (style, symbol) = if isFirst then (ButtonStyleSuccess, "[X]") else (ButtonStyleDanger, "[O]") + changeIf cb@Button {..} + | checkIsValid buttonCustomId && getxy tttxy == getxy buttonCustomId = cb {buttonDisabled = True, buttonStyle = style, buttonLabel = Just symbol} + | otherwise = cb + changeIf cb = cb + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent diff --git a/deps/discord-haskell/examples/ping-pong.hs b/deps/discord-haskell/examples/ping-pong.hs new file mode 100644 index 0000000..87ec08b --- /dev/null +++ b/deps/discord-haskell/examples/ping-pong.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text + +import Control.Monad (when, void) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import UnliftIO (liftIO) +import UnliftIO.Concurrent + +import Discord +import Discord.Types +import qualified Discord.Requests as R + +import ExampleUtils (getToken, getGuildId, actionWithChannelId) + +-- Allows this code to be an executable. See discord-haskell.cabal +main :: IO () +main = pingpongExample + +-- | Replies "pong" to every message that starts with "ping" +pingpongExample :: IO () +pingpongExample = do + tok <- getToken + testserverid <- getGuildId + + -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields + err <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler testserverid + , discordOnEnd = liftIO $ threadDelay (round (0.4 * 10^6)) >> putStrLn "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + , discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPresences =True} + } + + -- only reached on an unrecoverable error + -- put normal 'cleanup' code in discordOnEnd + TIO.putStrLn err + +-- If the start handler throws an exception, discord-haskell will gracefully shutdown +-- Use place to execute commands you know you want to complete +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do + liftIO $ putStrLn "Started ping-pong bot" + + let activity = def { activityName = "ping-pong" + , activityType = ActivityTypeGame + } + let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = UpdateStatusOnline + , updateStatusOptsAFK = False + } + sendCommand (UpdateStatus opts) + + actionWithChannelId testserverid $ \cid -> + void $ + restCall $ + R.CreateMessage + cid + "Hello! I will reply to pings with pongs" + + +-- If an event handler throws an exception, discord-haskell will continue to run +eventHandler :: Event -> DiscordHandler () +eventHandler event = case event of + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + void $ restCall (R.CreateReaction (messageChannelId m, messageId m) "eyes") + threadDelay (2 * 10 ^ (6 :: Int)) + + -- A very simple message. + Right m' <- restCall (R.CreateMessage (messageChannelId m) "Pong") + void $ restCall (R.EditMessage (messageChannelId m, messageId m') (def {R.messageDetailedContent=messageContent m' <> "!"})) + + latency <- getGatewayLatency + mLatency <- measureLatency + + -- A more complex message. Text-to-speech, does not mention everyone nor + -- the user, and uses Discord native replies. + -- Use ":info" in ghci to explore the type + let opts :: R.MessageDetailedOpts + opts = def { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!. Here's the current gateway latency: " <> (T.pack . show) ([latency, mLatency]) + , R.messageDetailedTTS = True + , R.messageDetailedAllowedMentions = Just $ + def { R.mentionEveryone = False + , R.mentionRepliedUser = False + } + , R.messageDetailedReference = Just $ + def { referenceMessageId = Just $ messageId m } + } + void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts) + _ -> return () + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent diff --git a/deps/discord-haskell/examples/rest-without-gateway.hs b/deps/discord-haskell/examples/rest-without-gateway.hs new file mode 100644 index 0000000..5627f06 --- /dev/null +++ b/deps/discord-haskell/examples/rest-without-gateway.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Control.Monad (forever) +import Control.Concurrent -- Chans and Threads + +import Discord.Types +import qualified Discord.Requests as R + +import Discord.Internal.Rest (startRestThread, writeRestCall, RestCallInternalException(..)) + +import ExampleUtils (getToken, getGuildId) + +{- +Peel back the `runDiscord` abstraction + +Send an HTTP restcall without logging into the gateway +-} +main :: IO () +main = do + tok <- getToken + testserverid <- getGuildId + + -- SETUP LOG + printQueue <- newChan :: IO (Chan T.Text) + printThreadId <- forkIO $ forever $ readChan printQueue >>= TIO.putStrLn + + -- START REST LOOP THREAD + (restChan, restThreadId) <- startRestThread (Auth tok) printQueue + + -- a rest call to get the channels in which we will post a message + Right cs <- writeRestCall restChan (R.GetGuildChannels testserverid) + + -- ONE REST CALL + resp <- writeRestCall restChan (R.CreateMessage (channelId (head $ filter isTextChannel cs)) "Message") + case resp of + Right msg -> print $ "created message: " <> show msg + Left (RestCallInternalErrorCode _code _status _body) -> print "4XX style http error code" + Left (RestCallInternalHttpException _err) -> print "http exception (likely no connection)" + Left (RestCallInternalNoParse _err _jsondata) -> print "can't parse return JSON" + + -- CLEANUP + killThread printThreadId + killThread restThreadId + where + isTextChannel :: Channel -> Bool + isTextChannel ChannelText {} = True + isTextChannel _ = False diff --git a/deps/discord-haskell/examples/state-counter.hs b/deps/discord-haskell/examples/state-counter.hs new file mode 100644 index 0000000..f017d9c --- /dev/null +++ b/deps/discord-haskell/examples/state-counter.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Monad (when, void, forever) +import UnliftIO (try, IOException) -- liftIO +import UnliftIO.MVar +import UnliftIO.Chan +import UnliftIO.Concurrent (forkIO, killThread) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Discord +import Discord.Types +import qualified Discord.Requests as R + +import ExampleUtils (getToken) + +main :: IO () +main = stateExample + +data State = State { pingCount :: Integer } + deriving (Show, Read, Eq, Ord) + +-- | Counts how many pings we've seen across sessions +stateExample :: IO () +stateExample = do + tok <- getToken + + -- eventHandler is called concurrently, need to sync stdout + printQueue <- newChan :: IO (Chan T.Text) + threadId <- forkIO $ forever $ readChan printQueue >>= TIO.putStrLn + + -- try to read previous state, otherwise use 0 + state :: MVar (State) <- do + mfile <- try $ read . T.unpack <$> TIO.readFile "./cachedState" + s <- case mfile of + Right file -> do + writeChan printQueue "loaded state from file" + pure file + Left (_ :: IOException) -> do + writeChan printQueue "created new state" + pure $ State { pingCount = 0 } + newMVar s + + t <- runDiscord $ def { discordToken = tok + , discordOnStart = writeChan printQueue "starting ping loop" + , discordOnEvent = eventHandler state printQueue + , discordOnEnd = do killThread threadId + -- + s <- readMVar state + TIO.writeFile "./cachedState" (T.pack (show s)) + } + TIO.putStrLn t + + +eventHandler :: MVar State -> Chan T.Text -> Event -> DiscordHandler () +eventHandler state printQueue event = case event of + -- respond to message, and modify state + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + writeChan printQueue "got a ping!" + + s <- takeMVar state + + void $ restCall (R.CreateMessage (messageChannelId m) (T.pack ("Pong #" <> show (pingCount s)))) + + putMVar state $ State { pingCount = pingCount s + 1 } + + _ -> pure () + + +fromBot :: Message -> Bool +fromBot = userIsBot . messageAuthor + +isPing :: Message -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageContent -- cgit v1.2.3