diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -8,7 +8,11 @@ - -# 1.15.1 +## 1.15.2 + +- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/143) Adding some utility and fixing some versions in place + +## 1.15.1 - [Geometer1729](https://github.com/discord-haskell/discord-haskell/pull/141) Fixing a bug in localization code diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,7 +1,6 @@ cabal-version: 2.0 name: discord-haskell --- library version is also noted at src/Discord/Rest/Prelude.hs -version: 1.15.1 +version: 1.15.2 description: Functions and data types to write discord bots. Official discord docs . . @@ -25,34 +24,87 @@ location: https://github.com/discord-haskell/discord-haskell.git executable ping-pong - main-is: examples/ping-pong.hs + main-is: ping-pong.hs default-language: Haskell2010 - ghc-options: -Wall - -fno-warn-type-defaults -fno-warn-unused-record-wildcards - -threaded + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils build-depends: base , text , unliftio , discord-haskell --- executable interaction-commands --- main-is: examples/interaction-commands.hs --- default-language: Haskell2010 --- ghc-options: -Wall --- -fno-warn-type-defaults -fno-warn-unused-record-wildcards --- -threaded --- build-depends: base --- , text --- , unliftio --- , discord-haskell --- , bytestring +executable interaction-commands + main-is: interaction-commands.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + , bytestring +executable cache + main-is: cache.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable gateway + main-is: gateway.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable rest-without-gateway + main-is: rest-without-gateway.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + +executable state-counter + main-is: state-counter.hs + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded + hs-source-dirs: examples + other-modules: + ExampleUtils + build-depends: base + , text + , unliftio + , discord-haskell + library - ghc-options: -Wall - -fno-warn-type-defaults -fno-warn-unused-record-wildcards -Wunused-packages + ghc-options: -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards hs-source-dirs: src default-language: Haskell2010 - exposed-modules: + other-modules: + Paths_discord_haskell + autogen-modules: + Paths_discord_haskell + exposed-modules: Discord , Discord.Types , Discord.Handle @@ -88,7 +140,9 @@ , Discord.Internal.Types.Emoji , Discord.Internal.Types.ScheduledEvents build-depends: - base ==4.*, + -- https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/libraries/version-history + -- below also sets the GHC version effectively. set to == 8.10.*, == 9.0.*. + base == 4.14.* || == 4.15.*, aeson >= 1.5 && < 1.6 || >= 2.0 && < 2.2, async >=2.2 && <2.3, bytestring >=0.10 && <0.11, diff --git a/examples/ExampleUtils.hs b/examples/ExampleUtils.hs new file mode 100644 --- /dev/null +++ b/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/examples/cache.hs b/examples/cache.hs new file mode 100644 --- /dev/null +++ b/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/examples/gateway.hs b/examples/gateway.hs new file mode 100644 --- /dev/null +++ b/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/examples/interaction-commands.hs b/examples/interaction-commands.hs new file mode 100644 --- /dev/null +++ b/examples/interaction-commands.hs @@ -0,0 +1,465 @@ +{-# 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 [ApplicationCommandChannelTypeGuildVoice]), + 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 + [ 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) + ) + ], + 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/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text -import System.Exit (exitSuccess) -import Control.Monad (when, forM_, void) +import Control.Monad (when, void) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -12,30 +11,21 @@ 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 - - --- check the url in a discord server --- --- https://discord.com/channels/2385235298674262408/4286572469284672046 -testserverid :: GuildId -testserverid = -1 - -- | Replies "pong" to every message that starts with "ping" pingpongExample :: IO () pingpongExample = do - when (testserverid == (-1 :: GuildId)) $ do - TIO.putStrLn "ERROR: modify the source and set testserverid to your serverid" - exitSuccess - - tok <- TIO.readFile "./examples/auth-token.secret" + tok <- getToken + testserverid <- getGuildId -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields err <- runDiscord $ def { discordToken = tok - , discordOnStart = startHandler + , discordOnStart = startHandler testserverid , discordOnEnd = liftIO $ threadDelay (round (0.4 * 10^6)) >> putStrLn "Ended" , discordOnEvent = eventHandler , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" @@ -48,8 +38,8 @@ -- If the start handler throws an exception, discord-haskell will gracefully shutdown -- Use place to execute commands you know you want to complete -startHandler :: DiscordHandler () -startHandler = do +startHandler :: GuildId -> DiscordHandler () +startHandler testserverid = do liftIO $ putStrLn "Started ping-pong bot" let activity = def { activityName = "ping-pong" @@ -62,10 +52,12 @@ } sendCommand (UpdateStatus opts) - Right chans <- restCall $ R.GetGuildChannels testserverid - forM_ (take 1 (filter isTextChannel chans)) - (\channel -> restCall $ R.CreateMessage (channelId channel) - "Hello! I will reply to pings with pongs") + 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 @@ -94,10 +86,6 @@ } void $ restCall (R.CreateMessageDetailed (messageChannelId m) opts) _ -> return () - -isTextChannel :: Channel -> Bool -isTextChannel (ChannelText {}) = True -isTextChannel _ = False fromBot :: Message -> Bool fromBot = userIsBot . messageAuthor diff --git a/examples/rest-without-gateway.hs b/examples/rest-without-gateway.hs new file mode 100644 --- /dev/null +++ b/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/examples/state-counter.hs b/examples/state-counter.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs --- a/src/Discord/Internal/Rest/Prelude.hs +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -9,6 +9,7 @@ import Prelude hiding (log) import Control.Exception.Safe (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.String (IsString(fromString)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -17,6 +18,9 @@ import Discord.Internal.Types +import Paths_discord_haskell (version) +import Data.Version (showVersion) + -- | The api version to use. apiVersion :: T.Text apiVersion = "10" @@ -34,7 +38,7 @@ where -- | https://discord.com/developers/docs/reference#user-agent -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/discord-haskell/discord-haskell, 1.15.1)" + agent = fromString $ "DiscordBot (https://github.com/discord-haskell/discord-haskell, " <> showVersion version <> ")" -- Possibly append to an URL infixl 5 /?