discord-haskell 1.15.1 → 1.15.2
raw patch · 10 files changed
+798/−49 lines, 10 filesdep ~basedep ~bytestringdep ~textnew-component:exe:cachenew-component:exe:gatewaynew-component:exe:interaction-commandsnew-component:exe:rest-without-gatewaynew-component:exe:state-counter
Dependency ranges changed: base, bytestring, text, unliftio
Files
- changelog.md +5/−1
- discord-haskell.cabal +75/−21
- examples/ExampleUtils.hs +29/−0
- examples/cache.hs +27/−0
- examples/gateway.hs +53/−0
- examples/interaction-commands.hs +465/−0
- examples/ping-pong.hs +14/−26
- examples/rest-without-gateway.hs +50/−0
- examples/state-counter.hs +75/−0
- src/Discord/Internal/Rest/Prelude.hs +5/−1
changelog.md view
@@ -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
discord-haskell.cabal view
@@ -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 <https://discord.com/developers/docs/reference>. .@@ -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,
+ examples/ExampleUtils.hs view
@@ -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
+ examples/cache.hs view
@@ -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 ()+
+ examples/gateway.hs view
@@ -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)
+ examples/interaction-commands.hs view
@@ -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
examples/ping-pong.hs view
@@ -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--- <server id> <channel id>--- 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
+ examples/rest-without-gateway.hs view
@@ -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
+ examples/state-counter.hs view
@@ -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
src/Discord/Internal/Rest/Prelude.hs view
@@ -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 /?