diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 17120a6a..9f528400 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -11,15 +11,17 @@ on: jobs: # TODO: autoformatting - #ormolu: - # runs-on: ubuntu-latest - # steps: - # - uses: actions/checkout@v2 - # - uses: mrkkrp/ormolu-action@v4 + brittany: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2 + - uses: tfausak/brittany-action@v1 + with: + version: 0.13.1.2 build: name: Build runs-on: ubuntu-latest - #needs: ormolu + needs: brittany steps: - uses: actions/checkout@v2 - uses: haskell/actions/setup@v1 diff --git a/brittany.sh b/brittany.sh new file mode 100755 index 00000000..eddc8055 --- /dev/null +++ b/brittany.sh @@ -0,0 +1 @@ +brittany --config-file=brittany.yaml --write-mode=inplace $(git ls-files '*.hs') diff --git a/brittany.yaml b/brittany.yaml new file mode 100644 index 00000000..8e950dca --- /dev/null +++ b/brittany.yaml @@ -0,0 +1,48 @@ +conf_disable_formatting: false +conf_debug: + dconf_roundtrip_exactprint_only: false + dconf_dump_bridoc_simpl_par: false + dconf_dump_ast_unknown: false + dconf_dump_bridoc_simpl_floating: false + dconf_dump_config: false + dconf_dump_bridoc_raw: false + dconf_dump_bridoc_final: false + dconf_dump_bridoc_simpl_alt: false + dconf_dump_bridoc_simpl_indent: false + dconf_dump_annotations: false + dconf_dump_bridoc_simpl_columns: false + dconf_dump_ast_full: false +conf_forward: + options_ghc: [] +conf_errorHandling: + econf_ExactPrintFallback: ExactPrintFallbackModeInline + econf_Werror: false + econf_omit_output_valid_check: false + econf_produceOutputOnErrors: false +conf_preprocessor: + ppconf_CPPMode: CPPModeAbort + ppconf_hackAroundIncludes: false +conf_obfuscate: false +conf_roundtrip_exactprint_only: false +conf_version: 1 +conf_layout: + lconfig_reformatModulePreamble: true + lconfig_altChooser: + tag: AltChooserBoundedSearch + contents: 3 + lconfig_allowSingleLineExportList: false + lconfig_importColumn: 50 + lconfig_hangingTypeSignature: false + lconfig_importAsColumn: 50 + lconfig_alignmentLimit: 30 + lconfig_allowHangingQuasiQuotes: true + lconfig_indentListSpecial: true + lconfig_indentAmount: 2 + lconfig_alignmentBreakOnMultiline: true + lconfig_experimentalSemicolonNewlines: false + lconfig_cols: 80 + lconfig_indentPolicy: IndentPolicyFree + lconfig_indentWhereSpecial: true + lconfig_columnAlignMode: + tag: ColumnAlignModeMajority + contents: 0.7 diff --git a/examples/cache.hs b/examples/cache.hs index c87df849..c2e8901c 100644 --- a/examples/cache.hs +++ b/examples/cache.hs @@ -1,9 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -import qualified Data.Text.IO as TIO -import UnliftIO (liftIO) - -import Discord +import qualified Data.Text.IO as TIO +import Discord +import UnliftIO ( liftIO ) -- There's not much information in the Cache for now -- but this program will show you what its got @@ -13,11 +12,11 @@ cacheExample :: IO () cacheExample = do tok <- TIO.readFile "./examples/auth-token.secret" - _ <- runDiscord $ def { discordToken = tok - , discordOnStart = do - cache <- readCache - liftIO $ putStrLn ("Cached info from gateway: " <> show cache) - stopDiscord - } + _ <- 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 index 8615e513..3804cb1a 100644 --- a/examples/gateway.hs +++ b/examples/gateway.hs @@ -1,31 +1,33 @@ {-# 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 Control.Concurrent ( forkIO + , killThread + ) +import Control.Concurrent.Chan +import Control.Monad ( forever ) +import qualified Data.Text.IO as TIO +import UnliftIO ( liftIO ) -import Discord -import Discord.Types +import Discord +import Discord.Types -- | Prints every event as it happens gatewayExample :: IO () gatewayExample = do - tok <- TIO.readFile "./examples/auth-token.secret" + tok <- TIO.readFile "./examples/auth-token.secret" - outChan <- newChan :: IO (Chan String) + 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 - , discordOnEvent = eventHandler outChan - , discordOnEnd = killThread threadId - } + err <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler + , discordOnEvent = eventHandler outChan + , discordOnEnd = killThread threadId + } TIO.putStrLn err -- Events are enumerated in the discord docs @@ -37,8 +39,8 @@ eventHandler out event = liftIO $ writeChan out (show event <> "\n") startHandler :: DiscordHandler () startHandler = do let opts = RequestGuildMembersOpts - { requestGuildMembersOptsGuildId = 453207241294610442 - , requestGuildMembersOptsLimit = 100 + { requestGuildMembersOptsGuildId = -1 + , requestGuildMembersOptsLimit = 100 , requestGuildMembersOptsNamesStartingWith = "" } diff --git a/examples/interaction-commands.hs b/examples/interaction-commands.hs index ea6da031..c91f688c 100644 --- a/examples/interaction-commands.hs +++ b/examples/interaction-commands.hs @@ -3,36 +3,37 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -import Control.Monad (forM_, 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 Control.Monad ( forM_ + , 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 main :: IO () -main = - if testserverid == -1 - then TIO.putStrLn "ERROR: modify the source and set testserverid to your serverid" - else interactionCommandExample +main = if testserverid == -1 + then TIO.putStrLn + "ERROR: modify the source and set testserverid to your serverid" + else interactionCommandExample testserverid :: Snowflake testserverid = -1 void :: DiscordHandler (Either RestCallErrorCode b) -> DiscordHandler () void = - ( >>= - ( \case - Left e -> liftIO $ print e - Right _ -> return () - ) + (>>= (\case + Left e -> liftIO $ print e + Right _ -> return () + ) ) -- | Replies "pong" to every message that starts with "ping" @@ -41,16 +42,16 @@ interactionCommandExample = do tok <- TIO.readFile "./examples/auth-token.secret" -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields - t <- - runDiscord $ - def - { discordToken = tok, - discordOnStart = startHandler, - discordOnEnd = liftIO $ putStrLn "Ended", - discordOnEvent = eventHandler, - discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "", - discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPrecenses = True} - } + t <- runDiscord $ def + { discordToken = tok + , discordOnStart = startHandler + , discordOnEnd = liftIO $ putStrLn "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + , discordGatewayIntent = def { gatewayIntentMembers = True + , gatewayIntentPrecenses = True + } + } TIO.putStrLn t -- If the start handler throws an exception, discord-haskell will gracefully shutdown @@ -58,31 +59,23 @@ interactionCommandExample = do startHandler :: DiscordHandler () startHandler = do let activity = - def - { activityName = "ping-pong", - activityType = ActivityTypeGame - } - let opts = - UpdateStatusOpts - { updateStatusOptsSince = Nothing, - updateStatusOptsGame = Just activity, - updateStatusOptsNewStatus = UpdateStatusOnline, - updateStatusOptsAFK = False - } + def { activityName = "ping-pong", activityType = ActivityTypeGame } + let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity + , updateStatusOptsNewStatus = UpdateStatusOnline + , updateStatusOptsAFK = False + } sendCommand (UpdateStatus opts) chans' <- restCall $ R.GetGuildChannels testserverid either (const (return ())) - ( \chans -> - forM_ - (take 1 (filter isTextChannel chans)) - ( \channel -> - restCall $ - R.CreateMessage - (channelId channel) - "Hello! I will reply to pings with pongs" - ) + (\chans -> forM_ + (take 1 (filter isTextChannel chans)) + (\channel -> restCall $ R.CreateMessage + (channelId channel) + "Hello! I will reply to pings with pongs" + ) ) chans' @@ -93,123 +86,112 @@ exampleUserCommand = createApplicationCommandUser "usercomm" -- | Example slash command that has subcommands and multiple types of fields. newExampleSlashCommand :: Maybe CreateApplicationCommand newExampleSlashCommand = - createApplicationCommandChatInput - "subtest" - "testing out subcommands" - >>= \d -> - Just $ - d - { createApplicationCommandOptions = - Just - ( ApplicationCommandOptionsSubcommands - [ ApplicationCommandOptionSubcommandGroup - "frstsubcmdgrp" - "the sub command group" - [ ApplicationCommandOptionSubcommand - "frstsubcmd" - "the first sub sub command" - [ ApplicationCommandOptionValueString - "onestringinput" - "two options" - True - ( Right - [ Choice "green" "green", - Choice "red" "red" - ] - ), - ApplicationCommandOptionValueInteger "oneintinput" "choices galore" False (Left False) Nothing Nothing - ] - ], - ApplicationCommandOptionSubcommandOrGroupSubcommand $ - ApplicationCommandOptionSubcommand - "frstsubcmd" - "the first subcommand" - [ ApplicationCommandOptionValueString - "onestringinput" - "two options" - True - ( Right - [ Choice "yellow" "yellow", - Choice "blue" "blue" - ] - ) - ], - ApplicationCommandOptionSubcommandOrGroupSubcommand $ - ApplicationCommandOptionSubcommand - "sndsubcmd" - "the second subcommand" - [ ApplicationCommandOptionValueBoolean - "trueorfalse" - "true or false" - True, - ApplicationCommandOptionValueNumber - "numbercomm" - "number option" - False - (Left True) - (Just 3.1415) - (Just 101), - ApplicationCommandOptionValueInteger - "numbercomm2" - "another number option" - False - (Right [Choice "one" 1, Choice "two" 2, Choice "minus 1" (-1)]) - (Just $ -1) - (Just $ -2), - ApplicationCommandOptionValueInteger - "numbercomm3" - "another another number option" - False - (Left True) - (Just $ -50) - (Just 50), - ApplicationCommandOptionValueUser - "user" - "testing asking for a user" - False, - ApplicationCommandOptionValueChannel - "channel" - "testing asking for a channel" - False - (Just [ApplicationCommandChannelTypeGuildVoice]), - ApplicationCommandOptionValueMentionable - "mentionable" - "testing asking for a mentionable" - False - ] + createApplicationCommandChatInput "subtest" "testing out subcommands" + >>= \d -> Just $ d + { createApplicationCommandOptions = Just + (ApplicationCommandOptionsSubcommands + [ ApplicationCommandOptionSubcommandGroup + "frstsubcmdgrp" + "the sub command group" + [ ApplicationCommandOptionSubcommand + "frstsubcmd" + "the first sub sub command" + [ ApplicationCommandOptionValueString + "onestringinput" + "two options" + True + (Right [Choice "green" "green", Choice "red" "red"]) + , ApplicationCommandOptionValueInteger "oneintinput" + "choices galore" + False + (Left False) + Nothing + Nothing ] - ) + ] + , ApplicationCommandOptionSubcommandOrGroupSubcommand + $ ApplicationCommandOptionSubcommand + "frstsubcmd" + "the first subcommand" + [ ApplicationCommandOptionValueString + "onestringinput" + "two options" + True + (Right [Choice "yellow" "yellow", Choice "blue" "blue"]) + ] + , ApplicationCommandOptionSubcommandOrGroupSubcommand + $ ApplicationCommandOptionSubcommand + "sndsubcmd" + "the second subcommand" + [ ApplicationCommandOptionValueBoolean "trueorfalse" + "true or false" + True + , ApplicationCommandOptionValueNumber "numbercomm" + "number option" + False + (Left True) + (Just 3.1415) + (Just 101) + , ApplicationCommandOptionValueInteger + "numbercomm2" + "another number option" + False + (Right + [Choice "one" 1, Choice "two" 2, Choice "minus 1" (-1)] + ) + (Just $ -1) + (Just $ -2) + , ApplicationCommandOptionValueInteger + "numbercomm3" + "another another number option" + False + (Left True) + (Just $ -50) + (Just 50) + , ApplicationCommandOptionValueUser + "user" + "testing asking for a user" + False + , ApplicationCommandOptionValueChannel + "channel" + "testing asking for a channel" + False + (Just [ApplicationCommandChannelTypeGuildVoice]) + , ApplicationCommandOptionValueMentionable + "mentionable" + "testing asking for a mentionable" + False + ] + ] + ) } -- | An example slash command. exampleSlashCommand :: Maybe CreateApplicationCommand exampleSlashCommand = - createApplicationCommandChatInput - "test" - "here is a description" - >>= \cac -> - return $ - cac - { createApplicationCommandOptions = - Just $ - ApplicationCommandOptionsValues - [ ApplicationCommandOptionValueString - "randominput" - "I shall not" - True - (Right [Choice "firstOpt" "yay", Choice "secondOpt" "nay"]) - ] - } + createApplicationCommandChatInput "test" "here is a description" >>= \cac -> + return $ cac + { createApplicationCommandOptions = Just $ ApplicationCommandOptionsValues + [ ApplicationCommandOptionValueString + "randominput" + "I shall not" + True + (Right [Choice "firstOpt" "yay", Choice "secondOpt" "nay"]) + ] + } -exampleInteractionResponse :: InteractionDataApplicationCommandOptions -> InteractionResponse -exampleInteractionResponse (InteractionDataApplicationCommandOptionsValues [InteractionDataApplicationCommandOptionValueString {interactionDataApplicationCommandOptionValueStringValue = s}]) = - interactionResponseBasic (T.pack $ "Here's the reply! You chose: " ++ show s) -exampleInteractionResponse _ = - interactionResponseBasic - "Something unexpected happened - the value was not what I expected!" +exampleInteractionResponse + :: InteractionDataApplicationCommandOptions -> InteractionResponse +exampleInteractionResponse (InteractionDataApplicationCommandOptionsValues [InteractionDataApplicationCommandOptionValueString { interactionDataApplicationCommandOptionValueStringValue = 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" +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 @@ -226,218 +208,334 @@ eventHandler event = case event of -- 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} - } + 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 - [ ComponentActionRowButton - [ ComponentButton "Button 1" False ButtonStylePrimary "Button 1" (Just (mkEmoji "🔥")), - ComponentButton "Button 2" True ButtonStyleSuccess "Button 2" Nothing, - ComponentButtonUrl - "https://github.com/aquarial/discord-haskell" - False - "Button 3" - Nothing - ], - ComponentActionRowSelectMenu - ( ComponentSelectMenu - "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 [] + let + opts' :: R.MessageDetailedOpts + opts' = def + { R.messageDetailedContent = "An example of a message with buttons!" + , R.messageDetailedComponents = Just + [ ComponentActionRowButton + [ ComponentButton "Button 1" + False + ButtonStylePrimary + "Button 1" + (Just (mkEmoji "🔥")) + , ComponentButton "Button 2" + True + ButtonStyleSuccess + "Button 2" + Nothing + , ComponentButtonUrl "https://github.com/aquarial/discord-haskell" + False + "Button 3" + Nothing + ] + , ComponentActionRowSelectMenu + (ComponentSelectMenu + "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, createApplicationCommandChatInput "modal" "modal test"] - liftIO (putStrLn $ "number of application commands added " ++ show (length vs)) + vs <- mapM + (maybe (return (Left $ RestCallErrorCode 0 "" "")) + (restCall . R.CreateGuildApplicationCommand i testserverid) + ) + [ exampleSlashCommand + , exampleUserCommand + , newExampleSlashCommand + , createApplicationCommandChatInput "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 {interactionDataComponent = cb@InteractionDataComponentButton {interactionDataComponentCustomId = (T.take 3 -> "ttt")}, ..} -> case processTicTacToe cb interactionMessage of - [r] -> - void - ( restCall - ( R.CreateInteractionResponse - interactionId - interactionToken - (InteractionResponseUpdateMessage r) - ) + Right ls -> + liftIO $ putStrLn $ "number of application commands total " ++ show + (length ls) + InteractionCreate InteractionComponent { interactionDataComponent = cb@InteractionDataComponentButton { interactionDataComponentCustomId = (T.take 3 -> "ttt") }, ..} + -> case processTicTacToe cb interactionMessage of + [r] -> void + (restCall + (R.CreateInteractionResponse interactionId + interactionToken + (InteractionResponseUpdateMessage r) + ) ) - r : rs -> - void - ( restCall $ - R.CreateInteractionResponse + r : rs -> + void + (restCall $ R.CreateInteractionResponse interactionId interactionToken (InteractionResponseUpdateMessage r) + ) + >> mapM_ + ( restCall + . R.CreateFollowupInteractionMessage interactionApplicationId + interactionToken + ) + rs + _ -> return () + InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandUser { interactionDataApplicationCommandName = nm, interactionDataApplicationCommandTargetId = uid, ..}, ..} + -> void $ restCall + (R.CreateInteractionResponse + interactionId + interactionToken + (interactionResponseBasic $ "Command " <> nm <> T.pack + (" selected user: " ++ show uid) ) - >> mapM_ - ( restCall - . R.CreateFollowupInteractionMessage - interactionApplicationId - interactionToken + ) + InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = "test", interactionDataApplicationCommandOptions = Just d, ..}, ..} + -> void $ restCall + (R.CreateInteractionResponse interactionId + interactionToken + (exampleInteractionResponse d) + ) + InteractionCreate InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = "subtest", interactionDataApplicationCommandOptions = Just d, ..}, ..} + -> void $ restCall + (R.CreateInteractionResponse + interactionId + interactionToken + (interactionResponseBasic + ( T.pack + $ "oh boy, subcommands! welp, here's everything I got from that: " + <> show d ) - rs - _ -> return () - InteractionCreate InteractionApplicationCommand {interactionDataApplicationCommand = InteractionDataApplicationCommandUser {interactionDataApplicationCommandName = nm, interactionDataApplicationCommandTargetId = uid, ..}, ..} -> - void $ - restCall - (R.CreateInteractionResponse interactionId interactionToken (interactionResponseBasic $ "Command " <> nm <> T.pack (" selected user: " ++ show uid))) - InteractionCreate InteractionApplicationCommand {interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput {interactionDataApplicationCommandName = "test", interactionDataApplicationCommandOptions = Just d, ..}, ..} -> - void $ - restCall - (R.CreateInteractionResponse interactionId interactionToken (exampleInteractionResponse d)) - InteractionCreate InteractionApplicationCommand {interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput {interactionDataApplicationCommandName = "subtest", interactionDataApplicationCommandOptions = 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 {interactionDataComponent = InteractionDataComponentButton {..}, ..} -> - void $ - restCall - ( R.CreateInteractionResponse interactionId interactionToken $ - InteractionResponseChannelMessage - ( ( interactionResponseMessageBasic $ "You pressed the button " <> interactionDataComponentCustomId + ) + ) + InteractionCreate InteractionComponent { interactionDataComponent = InteractionDataComponentButton {..}, ..} + -> void $ restCall + ( R.CreateInteractionResponse interactionId interactionToken + $ InteractionResponseChannelMessage + (( interactionResponseMessageBasic + $ "You pressed the button " + <> interactionDataComponentCustomId + ) + { interactionResponseMessageFlags = Just + (InteractionResponseMessageFlags + [InteractionResponseMessageFlagEphermeral] + ) + } + ) + ) + InteractionCreate InteractionComponent { interactionDataComponent = InteractionDataComponentSelectMenu { interactionDataComponentValues = 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 ) - { interactionResponseMessageFlags = Just (InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]) - } ) + { 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 { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = "subtest", interactionDataApplicationCommandOptions = Just _, ..}, ..} + -> void + (restCall $ R.CreateInteractionResponse + interactionId + interactionToken + (InteractionResponseAutocompleteResult + (InteractionResponseAutocompleteInteger [Choice "five" 5]) ) - InteractionCreate InteractionComponent {interactionDataComponent = InteractionDataComponentSelectMenu {interactionDataComponentValues = 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 {interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput {interactionDataApplicationCommandName = "subtest", interactionDataApplicationCommandOptions = Just _, ..}, ..} -> void (restCall $ R.CreateInteractionResponse interactionId interactionToken (InteractionResponseAutocompleteResult (InteractionResponseAutocompleteInteger [Choice "five" 5]))) - InteractionCreate i@InteractionApplicationCommand {interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput {interactionDataApplicationCommandName = "modal"}} -> - void $ - restCall - ( R.CreateInteractionResponse - (interactionId i) - (interactionToken i) - ( InteractionResponseModal - ( InteractionResponseModalData - "customidmodal" - "modal title" - [mkComponentTextInput "textcid" "textlabel"] - ) - ) + InteractionCreate i@InteractionApplicationCommand { interactionDataApplicationCommand = InteractionDataApplicationCommandChatInput { interactionDataApplicationCommandName = "modal" } } + -> void $ restCall + (R.CreateInteractionResponse + (interactionId i) + (interactionToken i) + (InteractionResponseModal + (InteractionResponseModalData + "customidmodal" + "modal title" + [mkComponentTextInput "textcid" "textlabel"] + ) ) - InteractionCreate i@InteractionModalSubmit {interactionDataModal = idm} -> void $ restCall (R.CreateInteractionResponse (interactionId i) (interactionToken i) (interactionResponseBasic (T.pack (show idm)))) + ) + InteractionCreate i@InteractionModalSubmit { interactionDataModal = idm } -> + void $ restCall + (R.CreateInteractionResponse + (interactionId i) + (interactionToken i) + (interactionResponseBasic (T.pack (show idm))) + ) _ -> return () -processTicTacToe :: InteractionDataComponent -> Message -> [InteractionResponseMessage] -processTicTacToe (InteractionDataComponentButton 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) +processTicTacToe + :: InteractionDataComponent -> Message -> [InteractionResponseMessage] +processTicTacToe (InteractionDataComponentButton 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 (ComponentActionRowButton cs) = ComponentActionRowButton $ (\c -> c {componentButtonDisabled = True}) <$> cs - disableAll c = c -processTicTacToe _ _ = [interactionResponseMessageBasic "Sorry, I couldn't understand that button."] + ) + : [ interactionResponseMessageBasic + ("Player " <> T.singleton player <> " has won!") + | checkTicTacToe newComp + ] + where + player = T.last (messageContent m) + newComp' = updateTicTacToe (Just (cid, '0' == player)) + disableAll (ComponentActionRowButton cs) = + ComponentActionRowButton + $ (\c -> c { componentButtonDisabled = True }) + <$> cs + disableAll c = c +processTicTacToe _ _ = + [interactionResponseMessageBasic "Sorry, I couldn't understand that button."] checkTicTacToe :: [ComponentActionRow] -> 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 = (\(ComponentActionRowButton cbs) -> (\ComponentButton {componentButtonStyle = style} -> style) <$> cbs) <$> xs - unwrappedT = transpose unwrapped - diagonal [] = [] - diagonal ([] : _) = [] - diagonal (ys : yss) = head ys : diagonal (tail <$> yss) +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 = + (\(ComponentActionRowButton cbs) -> + (\ComponentButton { componentButtonStyle = style } -> style) <$> cbs + ) + <$> xs + unwrappedT = transpose unwrapped + diagonal [] = [] + diagonal ([] : _ ) = [] + diagonal (ys : yss) = head ys : diagonal (tail <$> yss) -updateTicTacToe :: Maybe (T.Text, Bool) -> [ComponentActionRow] -> [ComponentActionRow] -updateTicTacToe Nothing _ = (\y -> ComponentActionRowButton $ (\x -> ComponentButton (T.pack $ "ttt " <> show x <> show y) False ButtonStyleSecondary "[ ]" Nothing) <$> [0 .. 4]) <$> [0 .. 4] +updateTicTacToe + :: Maybe (T.Text, Bool) -> [ComponentActionRow] -> [ComponentActionRow] +updateTicTacToe Nothing _ = + (\y -> + ComponentActionRowButton + $ (\x -> ComponentButton (T.pack $ "ttt " <> show x <> show y) + False + ButtonStyleSecondary + "[ ]" + Nothing + ) + <$> [0 .. 4] + ) + <$> [0 .. 4] updateTicTacToe (Just (tttxy, isFirst)) car - | not (checkIsValid tttxy) = car - | otherwise = (\(ComponentActionRowButton cbs) -> ComponentActionRowButton (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@ComponentButton {..} - | checkIsValid componentButtonCustomId && getxy tttxy == getxy componentButtonCustomId = cb {componentButtonDisabled = True, componentButtonStyle = style, componentButtonLabel = symbol} - | otherwise = cb - changeIf cb = cb + | not (checkIsValid tttxy) + = car + | otherwise + = (\(ComponentActionRowButton cbs) -> + ComponentActionRowButton (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@ComponentButton {..} + | checkIsValid componentButtonCustomId + && getxy tttxy + == getxy componentButtonCustomId + = cb { componentButtonDisabled = True + , componentButtonStyle = style + , componentButtonLabel = symbol + } + | otherwise + = cb + changeIf cb = cb isTextChannel :: Channel -> Bool -isTextChannel ChannelText {} = True -isTextChannel _ = False +isTextChannel ChannelText{} = True +isTextChannel _ = False fromBot :: Message -> Bool fromBot = userIsBot . messageAuthor diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs index c510d007..d8eba41c 100644 --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -1,21 +1,26 @@ -{-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text +{-# LANGUAGE OverloadedStrings #-} + -- allows "strings" to be Data.Text -import Control.Monad (when, forM_, void) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO +import Control.Monad ( forM_ + , void + , when + ) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO -import UnliftIO (liftIO) -import UnliftIO.Concurrent +import UnliftIO ( liftIO ) +import UnliftIO.Concurrent -import Discord -import Discord.Types -import qualified Discord.Requests as R +import Discord +import qualified Discord.Requests as R +import Discord.Types -- Allows this code to be an executable. See discord-haskell.cabal main :: IO () main = if testserverid == -1 - then TIO.putStrLn "ERROR: modify the source and set testserverid to your serverid" - else pingpongExample + then TIO.putStrLn + "ERROR: modify the source and set testserverid to your serverid" + else pingpongExample @@ -31,13 +36,17 @@ pingpongExample = do tok <- TIO.readFile "./examples/auth-token.secret" -- open ghci and run [[ :info RunDiscordOpts ]] to see available fields - err <- runDiscord $ def { discordToken = tok - , discordOnStart = startHandler - , discordOnEnd = liftIO $ threadDelay (round (0.4 * 10^6)) >> putStrLn "Ended" - , discordOnEvent = eventHandler - , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" - , discordGatewayIntent = def {gatewayIntentMembers = True, gatewayIntentPrecenses =True} - } + err <- runDiscord $ def + { discordToken = tok + , discordOnStart = startHandler + , discordOnEnd = liftIO $ threadDelay (round (0.4 * 10 ^ 6)) >> putStrLn + "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + , discordGatewayIntent = def { gatewayIntentMembers = True + , gatewayIntentPrecenses = True + } + } -- only reached on an unrecoverable error -- put normal 'cleanup' code in discordOnEnd @@ -49,52 +58,63 @@ startHandler :: DiscordHandler () startHandler = do liftIO $ putStrLn "Started ping-pong bot" - let activity = def { activityName = "ping-pong" - , activityType = ActivityTypeGame - } - let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing - , updateStatusOptsGame = Just activity + let activity = + def { activityName = "ping-pong", activityType = ActivityTypeGame } + let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing + , updateStatusOptsGame = Just activity , updateStatusOptsNewStatus = UpdateStatusOnline - , updateStatusOptsAFK = False + , updateStatusOptsAFK = False } 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") + forM_ + (take 1 (filter isTextChannel chans)) + (\channel -> restCall $ R.CreateMessage + (channelId channel) + "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' <> "!"})) - - -- 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) - _ -> return () + 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' <> "!" }) + ) + + -- 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) + _ -> return () isTextChannel :: Channel -> Bool -isTextChannel (ChannelText {}) = True -isTextChannel _ = False +isTextChannel ChannelText{} = True +isTextChannel _ = False fromBot :: Message -> Bool fromBot = userIsBot . messageAuthor diff --git a/examples/state-counter.hs b/examples/state-counter.hs index a0b9908a..e3b95b74 100644 --- a/examples/state-counter.hs +++ b/examples/state-counter.hs @@ -1,50 +1,62 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -import Control.Monad (when, void, forever) -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import UnliftIO (liftIO, try, IOException) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO - -import Discord -import Discord.Types -import qualified Discord.Requests as R - -data State = State { pingCount :: Integer } +import Control.Concurrent ( forkIO + , killThread + ) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Monad ( forever + , void + , when + ) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import UnliftIO ( IOException + , liftIO + , try + ) + +import Discord +import qualified Discord.Requests as R +import Discord.Types + +data State = State + { pingCount :: Integer + } deriving (Show, Read, Eq, Ord) -- | Counts how many pings we've seen across sessions stateExample :: IO () stateExample = do - tok <- TIO.readFile "./examples/auth-token.secret" + tok <- TIO.readFile "./examples/auth-token.secret" -- eventHandler is called concurrently, need to sync stdout - printQueue <- newChan :: IO (Chan T.Text) + 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 = liftIO $ writeChan printQueue "starting ping loop" - , discordOnEvent = eventHandler state printQueue - , discordOnEnd = do killThread threadId - -- - s <- readMVar state - TIO.writeFile "./cachedState" (T.pack (show s)) - } + 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 = liftIO $ 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 @@ -56,7 +68,10 @@ eventHandler state printQueue event = case event of s <- liftIO $ takeMVar state - void $ restCall (R.CreateMessage (messageChannelId m) (T.pack ("Pong #" <> show (pingCount s)))) + void $ restCall + (R.CreateMessage (messageChannelId m) + (T.pack ("Pong #" <> show (pingCount s))) + ) liftIO $ putMVar state $ State { pingCount = pingCount s + 1 } diff --git a/src/Discord.hs b/src/Discord.hs index 112d1adc..aced0ec3 100644 --- a/src/Discord.hs +++ b/src/Discord.hs @@ -8,9 +8,7 @@ module Discord , sendCommand , readCache , stopDiscord - , DiscordHandler - , DiscordHandle , Cache(..) , RestCallErrorCode(..) @@ -19,66 +17,82 @@ module Discord , def ) where -import Prelude hiding (log) -import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever) -import Data.Aeson (FromJSON) -import Data.Default (Default, def) -import Data.IORef (writeIORef) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - -import UnliftIO (race, try, finally, SomeException, IOException) -import UnliftIO.Concurrent - -import Discord.Handle -import Discord.Internal.Rest -import Discord.Internal.Rest.User (UserRequest(GetCurrentUser)) -import Discord.Internal.Gateway +import Control.Monad.Reader ( ReaderT + , ask + , forever + , liftIO + , runReaderT + , void + ) +import Data.Aeson ( FromJSON ) +import Data.Default ( Default + , def + ) +import Data.IORef ( writeIORef ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Prelude hiding ( log ) + +import UnliftIO ( IOException + , SomeException + , finally + , race + , try + ) +import UnliftIO.Concurrent + +import Discord.Handle +import Discord.Internal.Gateway +import Discord.Internal.Rest +import Discord.Internal.Rest.User ( UserRequest(GetCurrentUser) ) type DiscordHandler = ReaderT DiscordHandle IO data RunDiscordOpts = RunDiscordOpts - { discordToken :: T.Text - , discordOnStart :: DiscordHandler () - , discordOnEnd :: IO () - , discordOnEvent :: Event -> DiscordHandler () - , discordOnLog :: T.Text -> IO () + { discordToken :: T.Text + , discordOnStart :: DiscordHandler () + , discordOnEnd :: IO () + , discordOnEvent :: Event -> DiscordHandler () + , discordOnLog :: T.Text -> IO () , discordForkThreadForEvents :: Bool - , discordGatewayIntent :: GatewayIntent + , discordGatewayIntent :: GatewayIntent } instance Default RunDiscordOpts where - def = RunDiscordOpts { discordToken = "" - , discordOnStart = pure () - , discordOnEnd = pure () - , discordOnEvent = \_ -> pure () - , discordOnLog = \_ -> pure () + def = RunDiscordOpts { discordToken = "" + , discordOnStart = pure () + , discordOnEnd = pure () + , discordOnEvent = \_ -> pure () + , discordOnLog = \_ -> pure () , discordForkThreadForEvents = True - , discordGatewayIntent = def + , discordGatewayIntent = def } runDiscord :: RunDiscordOpts -> IO T.Text runDiscord opts = do - log <- newChan - logId <- liftIO $ startLogger (discordOnLog opts) log + log <- newChan + logId <- liftIO $ startLogger (discordOnLog opts) log (cache, cacheId) <- liftIO $ startCacheThread log - (rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log - (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) (discordGatewayIntent opts) cache log + (rest , restId ) <- liftIO $ startRestThread (Auth (discordToken opts)) log + (gate , gateId ) <- liftIO $ startGatewayThread (Auth (discordToken opts)) + (discordGatewayIntent opts) + cache + log libE <- newEmptyMVar - let handle = DiscordHandle { discordHandleRestChan = rest - , discordHandleGateway = gate - , discordHandleCache = cache - , discordHandleLog = log - , discordHandleLibraryError = libE - , discordHandleThreads = - [ HandleThreadIdLogger logId - , HandleThreadIdRest restId - , HandleThreadIdCache cacheId - , HandleThreadIdGateway gateId - ] - } + let handle = DiscordHandle + { discordHandleRestChan = rest + , discordHandleGateway = gate + , discordHandleCache = cache + , discordHandleLog = log + , discordHandleLibraryError = libE + , discordHandleThreads = [ HandleThreadIdLogger logId + , HandleThreadIdRest restId + , HandleThreadIdCache cacheId + , HandleThreadIdGateway gateId + ] + } finally (runDiscordLoop handle opts) (discordOnEnd opts >> runReaderT stopDiscord handle) @@ -87,60 +101,91 @@ runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text runDiscordLoop handle opts = do resp <- liftIO $ writeRestCall (discordHandleRestChan handle) GetCurrentUser case resp of - Left (RestCallInternalErrorCode c e1 e2) -> libError $ - "HTTP Error Code " <> T.pack (show c) <> " " <> TE.decodeUtf8 e1 - <> " " <> TE.decodeUtf8 e2 - Left (RestCallInternalHttpException e) -> libError ("HTTP Exception - " <> T.pack (show e)) - Left (RestCallInternalNoParse _ _) -> libError "Couldn't parse GetCurrentUser" - _ -> do me <- liftIO . runReaderT (try $ discordOnStart opts) $ handle - case me of - Left (e :: SomeException) -> libError ("discordOnStart handler stopped on an exception:\n\n" <> T.pack (show e)) - Right _ -> loop + Left (RestCallInternalErrorCode c e1 e2) -> + libError + $ "HTTP Error Code " + <> T.pack (show c) + <> " " + <> TE.decodeUtf8 e1 + <> " " + <> TE.decodeUtf8 e2 + Left (RestCallInternalHttpException e) -> + libError ("HTTP Exception - " <> T.pack (show e)) + Left (RestCallInternalNoParse _ _) -> + libError "Couldn't parse GetCurrentUser" + _ -> do + me <- liftIO . runReaderT (try $ discordOnStart opts) $ handle + case me of + Left (e :: SomeException) -> libError + ( "discordOnStart handler stopped on an exception:\n\n" + <> T.pack (show e) + ) + Right _ -> loop where - libError :: T.Text -> IO T.Text - libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg - - loop :: IO T.Text - loop = do next <- race (readMVar (discordHandleLibraryError handle)) - (readChan (gatewayHandleEvents (discordHandleGateway handle))) - case next of - Left err -> libError err - Right (Left err) -> libError (T.pack (show err)) - Right (Right event) -> do - let userEvent = userFacingEvent event - let action = if discordForkThreadForEvents opts then void . forkIO - else id - action $ do me <- liftIO . runReaderT (try $ discordOnEvent opts userEvent) $ handle - case me of - Left (e :: SomeException) -> writeChan (discordHandleLog handle) - ("eventhandler - crashed on [" <> T.pack (show userEvent) <> "] " - <> " with error: " <> T.pack (show e)) - Right _ -> pure () - loop + libError :: T.Text -> IO T.Text + libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg + + loop :: IO T.Text + loop = do + next <- race + (readMVar (discordHandleLibraryError handle)) + (readChan (gatewayHandleEvents (discordHandleGateway handle))) + case next of + Left err -> libError err + Right (Left err ) -> libError (T.pack (show err)) + Right (Right event) -> do + let userEvent = userFacingEvent event + let action = + if discordForkThreadForEvents opts then void . forkIO else id + action $ do + me <- + liftIO . runReaderT (try $ discordOnEvent opts userEvent) $ handle + case me of + Left (e :: SomeException) -> writeChan + (discordHandleLog handle) + ( "eventhandler - crashed on [" + <> T.pack (show userEvent) + <> "] " + <> " with error: " + <> T.pack (show e) + ) + Right _ -> pure () + loop data RestCallErrorCode = RestCallErrorCode Int T.Text T.Text deriving (Show, Read, Eq, Ord) -- | Execute one http request and get a response -restCall :: (FromJSON a, Request (r a)) => r a -> DiscordHandler (Either RestCallErrorCode a) -restCall r = do h <- ask - empty <- isEmptyMVar (discordHandleLibraryError h) - if not empty - then pure (Left (RestCallErrorCode 400 "Library Stopped Working" "")) - else do - resp <- liftIO $ writeRestCall (discordHandleRestChan h) r - case resp of - Right x -> pure (Right x) - Left (RestCallInternalErrorCode c e1 e2) -> do - pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2))) - Left (RestCallInternalHttpException _) -> - threadDelay (10 * 10^(6 :: Int)) >> restCall r - Left (RestCallInternalNoParse err dat) -> do - let formaterr = T.pack ("restcall - parse exception [" <> err <> "]" - <> " while handling" <> show dat) - writeChan (discordHandleLog h) formaterr - pure (Left (RestCallErrorCode 400 "Library Parse Exception" formaterr)) +restCall + :: (FromJSON a, Request (r a)) + => r a + -> DiscordHandler (Either RestCallErrorCode a) +restCall r = do + h <- ask + empty <- isEmptyMVar (discordHandleLibraryError h) + if not empty + then pure (Left (RestCallErrorCode 400 "Library Stopped Working" "")) + else do + resp <- liftIO $ writeRestCall (discordHandleRestChan h) r + case resp of + Right x -> pure (Right x) + Left (RestCallInternalErrorCode c e1 e2) -> do + pure + (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2))) + Left (RestCallInternalHttpException _) -> + threadDelay (10 * 10 ^ (6 :: Int)) >> restCall r + Left (RestCallInternalNoParse err dat) -> do + let formaterr = T.pack + ( "restcall - parse exception [" + <> err + <> "]" + <> " while handling" + <> show dat + ) + writeChan (discordHandleLog h) formaterr + pure + (Left (RestCallErrorCode 400 "Library Parse Exception" formaterr)) -- | Send a user GatewaySendable sendCommand :: GatewaySendable -> DiscordHandler () @@ -148,37 +193,41 @@ sendCommand e = do h <- ask writeChan (gatewayHandleUserSendables (discordHandleGateway h)) e case e of - UpdateStatus opts -> liftIO $ writeIORef (gatewayHandleLastStatus (discordHandleGateway h)) (Just opts) + UpdateStatus opts -> liftIO $ writeIORef + (gatewayHandleLastStatus (discordHandleGateway h)) + (Just opts) _ -> pure () -- | Access the current state of the gateway cache readCache :: DiscordHandler Cache readCache = do - h <- ask + h <- ask merr <- readMVar (cacheHandleCache (discordHandleCache h)) case merr of - Left (c, _) -> pure c - Right c -> pure c + Left (c, _) -> pure c + Right c -> pure c -- | Stop all the background threads stopDiscord :: DiscordHandler () -stopDiscord = do h <- ask - _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed" - threadDelay (10^(6 :: Int) `div` 10) - mapM_ (killThread . toId) (discordHandleThreads h) - where toId t = case t of - HandleThreadIdRest a -> a - HandleThreadIdGateway a -> a - HandleThreadIdCache a -> a - HandleThreadIdLogger a -> a +stopDiscord = do + h <- ask + _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed" + threadDelay (10 ^ (6 :: Int) `div` 10) + mapM_ (killThread . toId) (discordHandleThreads h) + where + toId t = case t of + HandleThreadIdRest a -> a + HandleThreadIdGateway a -> a + HandleThreadIdCache a -> a + HandleThreadIdLogger a -> a startLogger :: (T.Text -> IO ()) -> Chan T.Text -> IO ThreadId -startLogger handle logC = forkIO $ forever $ - do me <- try $ readChan logC >>= handle - case me of - Right _ -> pure () - Left (_ :: IOException) -> - -- writeChan logC "Log handler failed" - pure () +startLogger handle logC = forkIO $ forever $ do + me <- try $ readChan logC >>= handle + case me of + Right _ -> pure () + Left (_ :: IOException) -> + -- writeChan logC "Log handler failed" + pure () diff --git a/src/Discord/Handle.hs b/src/Discord/Handle.hs index fe4b444e..df36d543 100644 --- a/src/Discord/Handle.hs +++ b/src/Discord/Handle.hs @@ -3,11 +3,16 @@ module Discord.Handle , HandleThreadId(..) ) where -import Control.Concurrent (ThreadId, Chan, MVar) -import qualified Data.Text as T +import Control.Concurrent ( Chan + , MVar + , ThreadId + ) +import qualified Data.Text as T -import Discord.Internal.Rest (RestChanHandle(..)) -import Discord.Internal.Gateway (GatewayHandle(..), CacheHandle(..)) +import Discord.Internal.Gateway ( CacheHandle(..) + , GatewayHandle(..) + ) +import Discord.Internal.Rest ( RestChanHandle(..) ) -- | Thread Ids marked by what type they are data HandleThreadId = HandleThreadIdRest ThreadId @@ -16,10 +21,10 @@ data HandleThreadId = HandleThreadIdRest ThreadId | HandleThreadIdGateway ThreadId data DiscordHandle = DiscordHandle - { discordHandleRestChan :: RestChanHandle - , discordHandleGateway :: GatewayHandle - , discordHandleCache :: CacheHandle - , discordHandleThreads :: [HandleThreadId] - , discordHandleLog :: Chan T.Text + { discordHandleRestChan :: RestChanHandle + , discordHandleGateway :: GatewayHandle + , discordHandleCache :: CacheHandle + , discordHandleThreads :: [HandleThreadId] + , discordHandleLog :: Chan T.Text , discordHandleLibraryError :: MVar T.Text } diff --git a/src/Discord/Interactions.hs b/src/Discord/Interactions.hs index 45be2dad..80c00c01 100644 --- a/src/Discord/Interactions.hs +++ b/src/Discord/Interactions.hs @@ -1,8 +1,7 @@ module Discord.Interactions - ( module Discord.Internal.Types.ApplicationCommands, - module Discord.Internal.Types.Interactions, - ) -where + ( module Discord.Internal.Types.ApplicationCommands + , module Discord.Internal.Types.Interactions + ) where -import Discord.Internal.Types.ApplicationCommands -import Discord.Internal.Types.Interactions +import Discord.Internal.Types.ApplicationCommands +import Discord.Internal.Types.Interactions diff --git a/src/Discord/Internal/Gateway.hs b/src/Discord/Internal/Gateway.hs index e6e3c78a..3aa10770 100644 --- a/src/Discord/Internal/Gateway.hs +++ b/src/Discord/Internal/Gateway.hs @@ -12,32 +12,54 @@ module Discord.Internal.Gateway , module Discord.Internal.Types ) where -import Prelude hiding (log) -import Control.Concurrent.Chan (newChan, dupChan, Chan) -import Control.Concurrent (forkIO, ThreadId, newEmptyMVar, MVar) -import Data.IORef (newIORef) -import qualified Data.Text as T +import Control.Concurrent ( MVar + , ThreadId + , forkIO + , newEmptyMVar + ) +import Control.Concurrent.Chan ( Chan + , dupChan + , newChan + ) +import Data.IORef ( newIORef ) +import qualified Data.Text as T +import Prelude hiding ( log ) -import Discord.Internal.Types (Auth, EventInternalParse, GatewayIntent) -import Discord.Internal.Gateway.EventLoop (connectionLoop, GatewayHandle(..), GatewayException(..)) -import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..)) +import Discord.Internal.Gateway.Cache ( Cache(..) + , CacheHandle(..) + , cacheLoop + ) +import Discord.Internal.Gateway.EventLoop + ( GatewayException(..) + , GatewayHandle(..) + , connectionLoop + ) +import Discord.Internal.Types ( Auth + , EventInternalParse + , GatewayIntent + ) startCacheThread :: Chan T.Text -> IO (CacheHandle, ThreadId) startCacheThread log = do events <- newChan :: IO (Chan (Either GatewayException EventInternalParse)) - cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache)) + cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache)) let cacheHandle = CacheHandle events cache tid <- forkIO $ cacheLoop cacheHandle log pure (cacheHandle, tid) -- | Create a Chan for websockets. This creates a thread that -- writes all the received EventsInternalParse to the Chan -startGatewayThread :: Auth -> GatewayIntent -> CacheHandle -> Chan T.Text -> IO (GatewayHandle, ThreadId) +startGatewayThread + :: Auth + -> GatewayIntent + -> CacheHandle + -> Chan T.Text + -> IO (GatewayHandle, ThreadId) startGatewayThread auth intent cacheHandle log = do events <- dupChan (cacheHandleEvents cacheHandle) - sends <- newChan + sends <- newChan status <- newIORef Nothing - seqid <- newIORef 0 + seqid <- newIORef 0 seshid <- newIORef "" let gatewayHandle = GatewayHandle events sends status seqid seshid tid <- forkIO $ connectionLoop auth intent gatewayHandle log diff --git a/src/Discord/Internal/Gateway/Cache.hs b/src/Discord/Internal/Gateway/Cache.hs index 9a66391c..d2fba601 100644 --- a/src/Discord/Internal/Gateway/Cache.hs +++ b/src/Discord/Internal/Gateway/Cache.hs @@ -3,23 +3,24 @@ -- | Query info about connected Guilds and Channels module Discord.Internal.Gateway.Cache where -import Prelude hiding (log) -import Control.Monad (forever) -import Control.Concurrent.MVar -import Control.Concurrent.Chan -import qualified Data.Map.Strict as M -import qualified Data.Text as T +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Monad ( forever ) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Prelude hiding ( log ) -import Discord.Internal.Types -import Discord.Internal.Gateway.EventLoop +import Discord.Internal.Gateway.EventLoop +import Discord.Internal.Types data Cache = Cache - { cacheCurrentUser :: User - , cacheDMChannels :: M.Map ChannelId Channel - , cacheGuilds :: M.Map GuildId Guild - , cacheChannels :: M.Map ChannelId Channel - , cacheApplication :: PartialApplication - } deriving (Show) + { cacheCurrentUser :: User + , cacheDMChannels :: M.Map ChannelId Channel + , cacheGuilds :: M.Map GuildId Guild + , cacheChannels :: M.Map ChannelId Channel + , cacheApplication :: PartialApplication + } + deriving Show data CacheHandle = CacheHandle { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse) @@ -28,39 +29,47 @@ data CacheHandle = CacheHandle cacheLoop :: CacheHandle -> Chan T.Text -> IO () cacheLoop cacheHandle log = do - ready <- readChan eventChan - case ready of - Right (InternalReady _ user dmChannels _unavailableGuilds _ _ pApp) -> do - let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels) - putMVar cache (Right (Cache user dmChans M.empty M.empty pApp)) - loop - Right r -> - writeChan log ("cache - stopping cache - expected Ready event, but got " <> T.pack (show r)) - Left e -> - writeChan log ("cache - stopping cache - gateway exception " <> T.pack (show e)) - where + ready <- readChan eventChan + case ready of + Right (InternalReady _ user dmChannels _unavailableGuilds _ _ pApp) -> do + let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels) + putMVar cache (Right (Cache user dmChans M.empty M.empty pApp)) + loop + Right r -> writeChan + log + ( "cache - stopping cache - expected Ready event, but got " + <> T.pack (show r) + ) + Left e -> writeChan + log + ("cache - stopping cache - gateway exception " <> T.pack (show e)) + where cache = cacheHandleCache cacheHandle eventChan = cacheHandleEvents cacheHandle loop :: IO () loop = forever $ do eventOrExcept <- readChan eventChan - minfo <- takeMVar cache + minfo <- takeMVar cache case minfo of - Left nope -> putMVar cache (Left nope) + Left nope -> putMVar cache (Left nope) Right info -> case eventOrExcept of - Left e -> putMVar cache (Left (info, e)) - Right event -> putMVar cache (Right (adjustCache info event)) + Left e -> putMVar cache (Left (info, e)) + Right event -> putMVar cache (Right (adjustCache info event)) adjustCache :: Cache -> EventInternalParse -> Cache adjustCache minfo event = case event of InternalGuildCreate guild -> - let newChans = maybe [] (map (setChanGuildID (guildId guild))) (guildChannels guild) - g = M.insert (guildId guild) (guild { guildChannels = Just newChans }) (cacheGuilds minfo) + let newChans = maybe [] + (map (setChanGuildID (guildId guild))) + (guildChannels guild) + g = M.insert (guildId guild) + (guild { guildChannels = Just newChans }) + (cacheGuilds minfo) c = M.unionWith const (M.fromList [ (channelId ch, ch) | ch <- newChans ]) (cacheChannels minfo) - in minfo { cacheGuilds = g, cacheChannels = c } + in minfo { cacheGuilds = g, cacheChannels = c } --InternalGuildUpdate guild -> do -- let g = M.insert (guildId guild) guild (cacheGuilds minfo) -- m2 = minfo { cacheGuilds = g } @@ -71,9 +80,7 @@ adjustCache minfo event = case event of -- m2 = minfo { cacheGuilds = g, cacheChannels = c } -- putMVar cache m2 InternalReady _ _ _ _ _ _ pa -> minfo { cacheApplication = pa } - _ -> minfo + _ -> minfo setChanGuildID :: GuildId -> Channel -> Channel -setChanGuildID s c = if channelIsInGuild c - then c { channelGuild = s } - else c +setChanGuildID s c = if channelIsInGuild c then c { channelGuild = s } else c diff --git a/src/Discord/Internal/Gateway/EventLoop.hs b/src/Discord/Internal/Gateway/EventLoop.hs index d6a4c4fd..199c65d9 100644 --- a/src/Discord/Internal/Gateway/EventLoop.hs +++ b/src/Discord/Internal/Gateway/EventLoop.hs @@ -5,30 +5,44 @@ -- people will need module Discord.Internal.Gateway.EventLoop where -import Prelude hiding (log) - -import Control.Monad (forever, void) -import Control.Monad.Random (getRandomR) -import Control.Concurrent.Async (race) -import Control.Concurrent.Chan -import Control.Concurrent (threadDelay, killThread, forkIO) -import Control.Exception.Safe (try, finally, SomeException) -import Data.IORef -import Data.Aeson (eitherDecode, encode) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.ByteString.Lazy as BL - -import Wuss (runSecureClient) -import Network.WebSockets (ConnectionException(..), Connection, - receiveData, sendTextData, sendClose) - -import Discord.Internal.Types -import Discord.Internal.Rest.Prelude (apiVersion) +import Prelude hiding ( log ) + +import Control.Concurrent ( forkIO + , killThread + , threadDelay + ) +import Control.Concurrent.Async ( race ) +import Control.Concurrent.Chan +import Control.Exception.Safe ( SomeException + , finally + , try + ) +import Control.Monad ( forever + , void + ) +import Control.Monad.Random ( getRandomR ) +import Data.Aeson ( eitherDecode + , encode + ) +import qualified Data.ByteString.Lazy as BL +import Data.IORef +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Network.WebSockets ( Connection + , ConnectionException(..) + , receiveData + , sendClose + , sendTextData + ) +import Wuss ( runSecureClient ) + +import Discord.Internal.Rest.Prelude ( apiVersion ) +import Discord.Internal.Types data GatewayHandle = GatewayHandle - { gatewayHandleEvents :: Chan (Either GatewayException EventInternalParse) + { gatewayHandleEvents :: Chan (Either GatewayException EventInternalParse) , gatewayHandleUserSendables :: Chan GatewaySendable , gatewayHandleLastStatus :: IORef (Maybe UpdateStatusOpts) , gatewayHandleLastSequenceId :: IORef Integer @@ -51,9 +65,9 @@ data LoopState = LoopStart -- | Enough info for library to send info to discord. data SendablesData = SendablesData { sendableConnection :: Connection - , librarySendables :: Chan GatewaySendableInternal - , startsendingUsers :: IORef Bool - , heartbeatInterval :: Integer + , librarySendables :: Chan GatewaySendableInternal + , startsendingUsers :: IORef Bool + , heartbeatInterval :: Integer } {- @@ -72,160 +86,204 @@ sequenceId :: Int id of last event received set by Resume, need heartbeat sessionId :: Text set by Ready, need reconnect -} -connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO () +connectionLoop + :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO () connectionLoop auth intent gatewayHandle log = outerloop LoopStart - where + where outerloop :: LoopState -> IO () outerloop state = do - mfirst <- firstmessage state - case mfirst of - Nothing -> pure () - Just first -> do - next <- try (startconnectionpls first) - case next :: Either SomeException LoopState of - Left _ -> do t <- getRandomR (3,20) - threadDelay (t * (10^(6 :: Int))) - writeChan log ("gateway - trying to reconnect after failure(s)") - outerloop LoopReconnect - Right n -> outerloop n + mfirst <- firstmessage state + case mfirst of + Nothing -> pure () + Just first -> do + next <- try (startconnectionpls first) + case next :: Either SomeException LoopState of + Left _ -> do + t <- getRandomR (3, 20) + threadDelay (t * 10 ^ (6 :: Int)) + writeChan log "gateway - trying to reconnect after failure(s)" + outerloop LoopReconnect + Right n -> outerloop n firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal) - firstmessage state = - case state of - LoopStart -> pure $ Just $ Identify auth intent (0, 1) - LoopReconnect -> do seqId <- readIORef (gatewayHandleLastSequenceId gatewayHandle) - seshId <- readIORef (gatewayHandleSessionId gatewayHandle) - if seshId == "" - then do writeChan log ("gateway - WARNING seshID was not set by READY?") - pure $ Just $ Identify auth intent (0, 1) - else pure $ Just $ Resume auth seshId seqId - LoopClosed -> pure Nothing + firstmessage state = case state of + LoopStart -> pure $ Just $ Identify auth intent (0, 1) + LoopReconnect -> do + seqId <- readIORef (gatewayHandleLastSequenceId gatewayHandle) + seshId <- readIORef (gatewayHandleSessionId gatewayHandle) + if seshId == "" + then do + writeChan log "gateway - WARNING seshID was not set by READY?" + pure $ Just $ Identify auth intent (0, 1) + else pure $ Just $ Resume auth seshId seqId + LoopClosed -> pure Nothing startconnectionpls :: GatewaySendableInternal -> IO LoopState - startconnectionpls first = runSecureClient "gateway.discord.gg" 443 ("/?v=" <> T.unpack apiVersion <>"&encoding=json") $ \conn -> do - msg <- getPayload conn log - case msg of - Right (Hello interval) -> do - - internal <- newChan :: IO (Chan GatewaySendableInternal) - us <- newIORef False - -- start event loop - let sending = SendablesData conn internal us interval - sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log - heart <- forkIO $ heartbeat sending (gatewayHandleLastSequenceId gatewayHandle) - - writeChan internal first - finally (runEventLoop gatewayHandle sending log) - (killThread heart >> killThread sendsId) - _ -> do - writeChan log "gateway - WARNING could not connect. Expected hello" - sendClose conn ("expected hello" :: BL.ByteString) - void $ forever $ void (receiveData conn :: IO BL.ByteString) - -- > after sendClose you should call receiveDataMessage until - -- > it throws an exception - -- haskell websockets documentation - threadDelay (3 * (10^(6 :: Int))) - pure LoopStart + startconnectionpls first = + runSecureClient "gateway.discord.gg" + 443 + ("/?v=" <> T.unpack apiVersion <> "&encoding=json") + $ \conn -> do + msg <- getPayload conn log + case msg of + Right (Hello interval) -> do + + internal <- newChan :: IO (Chan GatewaySendableInternal) + us <- newIORef False + -- start event loop + let sending = SendablesData conn internal us interval + sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log + heart <- forkIO $ heartbeat + sending + (gatewayHandleLastSequenceId gatewayHandle) + + writeChan internal first + finally (runEventLoop gatewayHandle sending log) + (killThread heart >> killThread sendsId) + _ -> do + writeChan log + "gateway - WARNING could not connect. Expected hello" + sendClose conn ("expected hello" :: BL.ByteString) + void $ forever $ void (receiveData conn :: IO BL.ByteString) + -- > after sendClose you should call receiveDataMessage until + -- > it throws an exception + -- haskell websockets documentation + threadDelay (3 * 10 ^ (6 :: Int)) + pure LoopStart runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState -runEventLoop thehandle sendablesData log = do loop - where +runEventLoop thehandle sendablesData log = loop + where eventChan = gatewayHandleEvents thehandle - loop = do + loop = do eitherPayload <- getPayloadTimeout sendablesData log case eitherPayload :: Either ConnectionException GatewayReceivable of - Right (Hello _interval) -> do writeChan log ("eventloop - unexpected hello") - loop - Right (Dispatch event sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq - writeChan eventChan (Right event) - case event of - (InternalReady _ _ _ _ seshID _ _) -> - writeIORef (gatewayHandleSessionId thehandle) seshID - _ -> writeIORef (startsendingUsers sendablesData) True - loop - Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq - writeChan (librarySendables sendablesData) (Heartbeat sq) - loop - Right (Reconnect) -> pure LoopReconnect - Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart - Right (HeartbeatAck) -> loop + Right (Hello _interval) -> do + writeChan log "eventloop - unexpected hello" + loop + Right (Dispatch event sq) -> do + writeIORef (gatewayHandleLastSequenceId thehandle) sq + writeChan eventChan (Right event) + case event of + (InternalReady _ _ _ _ seshID _ _) -> + writeIORef (gatewayHandleSessionId thehandle) seshID + _ -> writeIORef (startsendingUsers sendablesData) True + loop + Right (HeartbeatRequest sq) -> do + writeIORef (gatewayHandleLastSequenceId thehandle) sq + writeChan (librarySendables sendablesData) (Heartbeat sq) + loop + Right Reconnect -> pure LoopReconnect + Right (InvalidSession retry) -> + pure $ if retry then LoopReconnect else LoopStart + Right HeartbeatAck -> loop Right (ParseError _e) -> -- getPayload logs the parse error. nothing to do here - loop + loop Left (CloseRequest code str) -> case code of -- see Discord and MDN documentation on gateway close event codes -- https://discord.com/developers/docs/topics/opcodes-and-status-codes#gateway-gateway-close-event-codes -- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent#properties - 1000 -> pure LoopReconnect - 1001 -> pure LoopReconnect - 4000 -> pure LoopReconnect - 4006 -> pure LoopStart - 4007 -> pure LoopStart - 4014 -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello 0) $ - "Tried to declare an unauthorized GatewayIntent. " <> - "Use the discord app manager to authorize by following: " <> - "https://github.com/aquarial/discord-haskell/blob/master/docs/intents.md")) - pure LoopClosed - _ -> do writeChan log ("gateway - unknown websocket close code " <> T.pack (show code) - <> " [" <> TE.decodeUtf8 (BL.toStrict str) <> "]. Consider opening an issue " - <> "https://github.com/aquarial/discord-haskell/issues") - pure LoopStart + 1000 -> pure LoopReconnect + 1001 -> pure LoopReconnect + 4000 -> pure LoopReconnect + 4006 -> pure LoopStart + 4007 -> pure LoopStart + 4014 -> do + writeChan + eventChan + (Left + ( GatewayExceptionUnexpected (Hello 0) + $ "Tried to declare an unauthorized GatewayIntent. " + <> "Use the discord app manager to authorize by following: " + <> "https://github.com/aquarial/discord-haskell/blob/master/docs/intents.md" + ) + ) + pure LoopClosed + _ -> do + writeChan + log + ( "gateway - unknown websocket close code " + <> T.pack (show code) + <> " [" + <> TE.decodeUtf8 (BL.toStrict str) + <> "]. Consider opening an issue " + <> "https://github.com/aquarial/discord-haskell/issues" + ) + pure LoopStart Left _ -> pure LoopReconnect heartbeat :: SendablesData -> IORef Integer -> IO () heartbeat sendablesData seqKey = do - threadDelay (3 * 10^(6 :: Int)) + threadDelay (3 * 10 ^ (6 :: Int)) forever $ do num <- readIORef seqKey writeChan (librarySendables sendablesData) (Heartbeat num) threadDelay (fromInteger (heartbeatInterval sendablesData * 1000)) -getPayloadTimeout :: SendablesData -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) +getPayloadTimeout + :: SendablesData + -> Chan T.Text + -> IO (Either ConnectionException GatewayReceivable) getPayloadTimeout sendablesData log = do let interval = heartbeatInterval sendablesData - res <- race (threadDelay (fromInteger ((interval * 1000 * 3) `div` 2))) + res <- race (threadDelay (fromInteger (interval * 1000 * 3 `div` 2))) (getPayload (sendableConnection sendablesData) log) case res of - Left () -> pure (Right Reconnect) + Left () -> pure (Right Reconnect) Right other -> pure other -getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) +getPayload + :: Connection + -> Chan T.Text + -> IO (Either ConnectionException GatewayReceivable) getPayload conn log = try $ do msg' <- receiveData conn case eitherDecode msg' of Right msg -> pure msg - Left err -> do writeChan log ("gateway - received exception [" <> T.pack err <> "]" - <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg')) - pure (ParseError (T.pack err)) + Left err -> do + writeChan + log + ( "gateway - received exception [" + <> T.pack err + <> "]" + <> " while decoding " + <> TE.decodeUtf8 (BL.toStrict msg') + ) + pure (ParseError (T.pack err)) -- simple idea: send payloads from user/sys to connection -- has to be complicated though -sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO () +sendableLoop + :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO () sendableLoop conn ghandle sendablesData _log = sendSysLoop - where + where sendSysLoop = do - threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) - payload <- readChan (librarySendables sendablesData) - sendTextData conn (encode payload) - -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (encode payload))) - usersending <- readIORef (startsendingUsers sendablesData) - if not usersending + threadDelay $ round (10 ^ (6 :: Int) * (62 / 120) :: Double) + payload <- readChan (librarySendables sendablesData) + sendTextData conn (encode payload) + -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (encode payload))) + usersending <- readIORef (startsendingUsers sendablesData) + if not usersending then sendSysLoop - else do act <- readIORef (gatewayHandleLastStatus ghandle) - case act of Nothing -> pure () - Just opts -> sendTextData conn (encode (UpdateStatus opts)) - sendUserLoop + else do + act <- readIORef (gatewayHandleLastStatus ghandle) + case act of + Nothing -> pure () + Just opts -> sendTextData conn (encode (UpdateStatus opts)) + sendUserLoop sendUserLoop = do -- send a ~120 events a min by delaying - threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) - -- payload :: Either GatewaySendableInternal GatewaySendable - payload <- race (readChan (gatewayHandleUserSendables ghandle)) (readChan (librarySendables sendablesData)) - sendTextData conn (either encode encode payload) - -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload))) - sendUserLoop + threadDelay $ round (10 ^ (6 :: Int) * (62 / 120) :: Double) + -- payload :: Either GatewaySendableInternal GatewaySendable + payload <- race (readChan (gatewayHandleUserSendables ghandle)) + (readChan (librarySendables sendablesData)) + sendTextData conn (either encode encode payload) + -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload))) + sendUserLoop diff --git a/src/Discord/Internal/Rest.hs b/src/Discord/Internal/Rest.hs index 3b6f9c1b..9070112c 100644 --- a/src/Discord/Internal/Rest.hs +++ b/src/Discord/Internal/Rest.hs @@ -13,40 +13,58 @@ module Discord.Internal.Rest , RestCallInternalException(..) ) where -import Prelude hiding (log) -import Data.Aeson (FromJSON, eitherDecode) -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Concurrent (forkIO, ThreadId) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T +import Control.Concurrent ( ThreadId + , forkIO + ) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Data.Aeson ( FromJSON + , eitherDecode + ) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Prelude hiding ( log ) -import Discord.Internal.Types -import Discord.Internal.Rest.HTTP +import Discord.Internal.Rest.HTTP +import Discord.Internal.Types -data RestChanHandle = RestChanHandle - { restHandleChan :: Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) - } +newtype RestChanHandle = RestChanHandle + { restHandleChan + :: Chan + ( String + , JsonRequest + , MVar (Either RestCallInternalException BL.ByteString) + ) + } -- | Starts the http request thread. Please only call this once startRestThread :: Auth -> Chan T.Text -> IO (RestChanHandle, ThreadId) startRestThread auth log = do - c <- newChan + c <- newChan tid <- forkIO $ restLoop auth c log pure (RestChanHandle c, tid) -- | Execute a request blocking until a response is received -writeRestCall :: (Request (r a), FromJSON a) => RestChanHandle -> r a -> IO (Either RestCallInternalException a) +writeRestCall + :: (Request (r a), FromJSON a) + => RestChanHandle + -> r a + -> IO (Either RestCallInternalException a) writeRestCall c req = do m <- newEmptyMVar writeChan (restHandleChan c) (majorRoute req, jsonRequest req, m) r <- readMVar m pure $ case eitherDecode <$> r of - Right (Right o) -> Right o - (Right (Left er)) -> Left (RestCallInternalNoParse er (case r of - Right x -> x - Left _ -> "")) + Right (Right o) -> Right o + (Right (Left er)) -> Left + (RestCallInternalNoParse + er + (case r of + Right x -> x + Left _ -> "" + ) + ) Left e -> Left e diff --git a/src/Discord/Internal/Rest/ApplicationCommands.hs b/src/Discord/Internal/Rest/ApplicationCommands.hs index 119e46bc..e331d003 100644 --- a/src/Discord/Internal/Rest/ApplicationCommands.hs +++ b/src/Discord/Internal/Rest/ApplicationCommands.hs @@ -5,62 +5,67 @@ module Discord.Internal.Rest.ApplicationCommands where -import Data.Aeson (Value) -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types -import Discord.Internal.Types.ApplicationCommands - ( ApplicationCommandPermissions, - GuildApplicationCommandPermissions(GuildApplicationCommandPermissions), - EditApplicationCommand, - CreateApplicationCommand, - ApplicationCommand ) -import Network.HTTP.Req as R +import Data.Aeson ( Value ) +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Discord.Internal.Types.ApplicationCommands + ( ApplicationCommand + , ApplicationCommandPermissions + , CreateApplicationCommand + , EditApplicationCommand + , GuildApplicationCommandPermissions + ( GuildApplicationCommandPermissions + ) + ) +import Network.HTTP.Req as R instance Request (ApplicationCommandRequest a) where jsonRequest = applicationCommandJsonRequest - majorRoute = applicationCommandMajorRoute + majorRoute = applicationCommandMajorRoute data ApplicationCommandRequest a where - GetGlobalApplicationCommands :: ApplicationId -> ApplicationCommandRequest [ApplicationCommand] - CreateGlobalApplicationCommand :: ApplicationId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand - GetGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand - EditGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> EditApplicationCommand -> ApplicationCommandRequest ApplicationCommand - DeleteGlobalApplicationCommand :: ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest () - BulkOverWriteGlobalApplicationCommand :: ApplicationId -> [CreateApplicationCommand] -> ApplicationCommandRequest () - GetGuildApplicationCommands :: ApplicationId -> GuildId -> ApplicationCommandRequest [ApplicationCommand] - CreateGuildApplicationCommand :: ApplicationId -> GuildId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand - GetGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand - EditGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand - DeleteGuildApplicationCommand :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest () - BulkOverWriteGuildApplicationCommand :: ApplicationId -> GuildId -> [CreateApplicationCommand] -> ApplicationCommandRequest () - GetGuildApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandRequest GuildApplicationCommandPermissions - GetApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest GuildApplicationCommandPermissions - EditApplicationCommandPermissions :: ApplicationId -> GuildId -> ApplicationCommandId -> [ApplicationCommandPermissions] -> ApplicationCommandRequest GuildApplicationCommandPermissions + GetGlobalApplicationCommands ::ApplicationId -> ApplicationCommandRequest [ApplicationCommand] + CreateGlobalApplicationCommand ::ApplicationId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand + GetGlobalApplicationCommand ::ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand + EditGlobalApplicationCommand ::ApplicationId -> ApplicationCommandId -> EditApplicationCommand -> ApplicationCommandRequest ApplicationCommand + DeleteGlobalApplicationCommand ::ApplicationId -> ApplicationCommandId -> ApplicationCommandRequest () + BulkOverWriteGlobalApplicationCommand ::ApplicationId -> [CreateApplicationCommand] -> ApplicationCommandRequest () + GetGuildApplicationCommands ::ApplicationId -> GuildId -> ApplicationCommandRequest [ApplicationCommand] + CreateGuildApplicationCommand ::ApplicationId -> GuildId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand + GetGuildApplicationCommand ::ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest ApplicationCommand + EditGuildApplicationCommand ::ApplicationId -> GuildId -> ApplicationCommandId -> CreateApplicationCommand -> ApplicationCommandRequest ApplicationCommand + DeleteGuildApplicationCommand ::ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest () + BulkOverWriteGuildApplicationCommand ::ApplicationId -> GuildId -> [CreateApplicationCommand] -> ApplicationCommandRequest () + GetGuildApplicationCommandPermissions ::ApplicationId -> GuildId -> ApplicationCommandRequest GuildApplicationCommandPermissions + GetApplicationCommandPermissions ::ApplicationId -> GuildId -> ApplicationCommandId -> ApplicationCommandRequest GuildApplicationCommandPermissions + EditApplicationCommandPermissions ::ApplicationId -> GuildId -> ApplicationCommandId -> [ApplicationCommandPermissions] -> ApplicationCommandRequest GuildApplicationCommandPermissions -- | The only parameters needed in the GuildApplicationCommandPermissions -- objects are id and permissions. - BatchEditApplicationCommandPermissions :: ApplicationId -> GuildId -> [GuildApplicationCommandPermissions] -> ApplicationCommandRequest [GuildApplicationCommandPermissions] + BatchEditApplicationCommandPermissions ::ApplicationId -> GuildId -> [GuildApplicationCommandPermissions] -> ApplicationCommandRequest [GuildApplicationCommandPermissions] applications :: ApplicationId -> R.Url 'R.Https applications s = baseUrl /: "applications" // s applicationCommandMajorRoute :: ApplicationCommandRequest a -> String applicationCommandMajorRoute a = case a of - (GetGlobalApplicationCommands aid) -> "get_glob_appcomm" <> show aid + (GetGlobalApplicationCommands aid ) -> "get_glob_appcomm" <> show aid (CreateGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid - (GetGlobalApplicationCommand aid _) -> "get_glob_appcomm" <> show aid + (GetGlobalApplicationCommand aid _) -> "get_glob_appcomm" <> show aid (EditGlobalApplicationCommand aid _ _) -> "write_glob_appcomm" <> show aid (DeleteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid - (BulkOverWriteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid - (GetGuildApplicationCommands aid _) -> "get_appcomm" <> show aid - (CreateGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid - (GetGuildApplicationCommand aid _ _) -> "get_appcomm" <> show aid - (EditGuildApplicationCommand aid _ _ _) -> "write_appcomm" <> show aid - (DeleteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (BulkOverWriteGlobalApplicationCommand aid _) -> + "write_glob_appcomm" <> show aid + (GetGuildApplicationCommands aid _ ) -> "get_appcomm" <> show aid + (CreateGuildApplicationCommand aid _ _ ) -> "write_appcomm" <> show aid + (GetGuildApplicationCommand aid _ _ ) -> "get_appcomm" <> show aid + (EditGuildApplicationCommand aid _ _ _ ) -> "write_appcomm" <> show aid + (DeleteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid (BulkOverWriteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid - (GetGuildApplicationCommandPermissions aid _) -> "appcom_perm " <> show aid - (GetApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid - (EditApplicationCommandPermissions aid _ _ _) -> "appcom_perm " <> show aid - (BatchEditApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid + (GetGuildApplicationCommandPermissions aid _ ) -> "appcom_perm " <> show aid + (GetApplicationCommandPermissions aid _ _ ) -> "appcom_perm " <> show aid + (EditApplicationCommandPermissions aid _ _ _ ) -> "appcom_perm " <> show aid + (BatchEditApplicationCommandPermissions aid _ _) -> + "appcom_perm " <> show aid applicationCommandJsonRequest :: ApplicationCommandRequest a -> JsonRequest applicationCommandJsonRequest a = case a of @@ -78,24 +83,36 @@ applicationCommandJsonRequest a = case a of Put (applications aid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty (GetGuildApplicationCommands aid gid) -> Get (applications aid /: "guilds" // gid /: "commands") mempty - (CreateGuildApplicationCommand aid gid cac) -> - Post (applications aid /: "guilds" // gid /: "commands") (convert cac) mempty + (CreateGuildApplicationCommand aid gid cac) -> Post + (applications aid /: "guilds" // gid /: "commands") + (convert cac) + mempty (GetGuildApplicationCommand aid gid aci) -> Get (applications aid /: "guilds" // gid /: "commands" // aci) mempty - (EditGuildApplicationCommand aid gid aci eac) -> - Patch (applications aid /: "guilds" // gid /: "commands" // aci) (convert eac) mempty + (EditGuildApplicationCommand aid gid aci eac) -> Patch + (applications aid /: "guilds" // gid /: "commands" // aci) + (convert eac) + mempty (DeleteGuildApplicationCommand aid gid aci) -> Delete (applications aid /: "guilds" // gid /: "commands" // aci) mempty - (BulkOverWriteGuildApplicationCommand aid gid cacs) -> - Put (applications aid /: "guilds" // gid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty - (GetGuildApplicationCommandPermissions aid gid) -> - Get (applications aid /: "guilds" // gid /: "commands" /: "permissions") mempty - (GetApplicationCommandPermissions aid gid cid) -> - Get (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") mempty - (EditApplicationCommandPermissions aid gid cid ps) -> - Put (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") (R.ReqBodyJson $ toJSON (GuildApplicationCommandPermissions aid cid gid ps)) mempty - (BatchEditApplicationCommandPermissions aid gid ps) -> - Put (applications aid /: "guilds" // gid /: "commands" /: "permissions") (R.ReqBodyJson $ toJSON ps) mempty - where - convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) - convert = (pure @RestIO) . R.ReqBodyJson . toJSON + (BulkOverWriteGuildApplicationCommand aid gid cacs) -> Put + (applications aid /: "guilds" // gid /: "commands") + (R.ReqBodyJson $ toJSON cacs) + mempty + (GetGuildApplicationCommandPermissions aid gid) -> Get + (applications aid /: "guilds" // gid /: "commands" /: "permissions") + mempty + (GetApplicationCommandPermissions aid gid cid) -> Get + (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") + mempty + (EditApplicationCommandPermissions aid gid cid ps) -> Put + (applications aid /: "guilds" // gid /: "commands" // cid /: "permissions") + (R.ReqBodyJson $ toJSON (GuildApplicationCommandPermissions aid cid gid ps)) + mempty + (BatchEditApplicationCommandPermissions aid gid ps) -> Put + (applications aid /: "guilds" // gid /: "commands" /: "permissions") + (R.ReqBodyJson $ toJSON ps) + mempty + where + convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) + convert = (pure @RestIO) . R.ReqBodyJson . toJSON diff --git a/src/Discord/Internal/Rest/Channel.hs b/src/Discord/Internal/Rest/Channel.hs index 815ca37b..bafa1ccd 100644 --- a/src/Discord/Internal/Rest/Channel.hs +++ b/src/Discord/Internal/Rest/Channel.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} + {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,124 +22,130 @@ module Discord.Internal.Rest.Channel ) where -import Data.Aeson -import Data.Default (Default, def) -import Data.Emoji (unicodeByName) -import qualified Data.Text as T -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Network.HTTP.Client (RequestBody (RequestBodyBS)) -import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS) -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R - -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types -import Control.Monad (join) +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Default ( Default + , def + ) +import Data.Emoji ( unicodeByName ) +import qualified Data.Text as T +import Network.HTTP.Client ( RequestBody(RequestBodyBS) ) +import Network.HTTP.Client.MultipartFormData + ( partBS + , partFileRequestBody + ) +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R + +import Control.Monad ( join ) +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types instance Request (ChannelRequest a) where - majorRoute = channelMajorRoute + majorRoute = channelMajorRoute jsonRequest = channelJsonRequest -- | Data constructor for requests. See data ChannelRequest a where -- | Gets a channel by its id. - GetChannel :: ChannelId -> ChannelRequest Channel + GetChannel ::ChannelId -> ChannelRequest Channel -- | Edits channels options. - ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel + ModifyChannel ::ChannelId -> ModifyChannelOpts -> ChannelRequest Channel -- | Deletes a channel if its id doesn't equal to the id of guild. - DeleteChannel :: ChannelId -> ChannelRequest Channel + DeleteChannel ::ChannelId -> ChannelRequest Channel -- | Gets a messages from a channel with limit of 100 per request. - GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] + GetChannelMessages ::ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] -- | Gets a message in a channel by its id. - GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message + GetChannelMessage ::(ChannelId, MessageId) -> ChannelRequest Message -- | Sends a message to a channel. - CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message + CreateMessage ::ChannelId -> T.Text -> ChannelRequest Message -- | Sends a message with granular controls. - CreateMessageDetailed :: ChannelId -> MessageDetailedOpts -> ChannelRequest Message + CreateMessageDetailed ::ChannelId -> MessageDetailedOpts -> ChannelRequest Message -- | Add an emoji reaction to a message. ID must be present for custom emoji - CreateReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + CreateReaction ::(ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | Remove a Reaction this bot added - DeleteOwnReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + DeleteOwnReaction ::(ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | Remove a Reaction someone else added - DeleteUserReaction :: (ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () + DeleteUserReaction ::(ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () -- | Deletes all reactions of a single emoji on a message - DeleteSingleReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + DeleteSingleReaction ::(ChannelId, MessageId) -> T.Text -> ChannelRequest () -- | List of users that reacted with this emoji - GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest [User] + GetReactions ::(ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest [User] -- | Delete all reactions on a message - DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () + DeleteAllReactions ::(ChannelId, MessageId) -> ChannelRequest () -- | Edits a message content. - EditMessage :: (ChannelId, MessageId) -> MessageDetailedOpts + EditMessage ::(ChannelId, MessageId) -> MessageDetailedOpts -> ChannelRequest Message -- | Deletes a message. - DeleteMessage :: (ChannelId, MessageId) -> ChannelRequest () + DeleteMessage ::(ChannelId, MessageId) -> ChannelRequest () -- | Deletes a group of messages. - BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () + BulkDeleteMessage ::(ChannelId, [MessageId]) -> ChannelRequest () -- | Edits a permission overrides for a channel. - EditChannelPermissions :: ChannelId -> OverwriteId -> ChannelPermissionsOpts -> ChannelRequest () + EditChannelPermissions ::ChannelId -> OverwriteId -> ChannelPermissionsOpts -> ChannelRequest () -- | Gets all instant invites to a channel. - GetChannelInvites :: ChannelId -> ChannelRequest Object + GetChannelInvites ::ChannelId -> ChannelRequest Object -- | Creates an instant invite to a channel. - CreateChannelInvite :: ChannelId -> ChannelInviteOpts -> ChannelRequest Invite + CreateChannelInvite ::ChannelId -> ChannelInviteOpts -> ChannelRequest Invite -- | Deletes a permission override from a channel. - DeleteChannelPermission :: ChannelId -> OverwriteId -> ChannelRequest () + DeleteChannelPermission ::ChannelId -> OverwriteId -> ChannelRequest () -- | Sends a typing indicator a channel which lasts 10 seconds. - TriggerTypingIndicator :: ChannelId -> ChannelRequest () + TriggerTypingIndicator ::ChannelId -> ChannelRequest () -- | Gets all pinned messages of a channel. - GetPinnedMessages :: ChannelId -> ChannelRequest [Message] + GetPinnedMessages ::ChannelId -> ChannelRequest [Message] -- | Pins a message. - AddPinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + AddPinnedMessage ::(ChannelId, MessageId) -> ChannelRequest () -- | Unpins a message. - DeletePinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + DeletePinnedMessage ::(ChannelId, MessageId) -> ChannelRequest () -- | Adds a recipient to a Group DM using their access token - GroupDMAddRecipient :: ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () + GroupDMAddRecipient ::ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () -- | Removes a recipient from a Group DM - GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () + GroupDMRemoveRecipient ::ChannelId -> UserId -> ChannelRequest () -- | Start a thread from a message - StartThreadFromMessage :: ChannelId -> MessageId -> StartThreadOpts -> ChannelRequest Channel + StartThreadFromMessage ::ChannelId -> MessageId -> StartThreadOpts -> ChannelRequest Channel -- | Start a thread without a message - StartThreadNoMessage :: ChannelId -> StartThreadNoMessageOpts -> ChannelRequest Channel + StartThreadNoMessage ::ChannelId -> StartThreadNoMessageOpts -> ChannelRequest Channel -- | Join a thread - JoinThread :: ChannelId -> ChannelRequest () + JoinThread ::ChannelId -> ChannelRequest () -- | Add a thread member - AddThreadMember :: ChannelId -> UserId -> ChannelRequest () + AddThreadMember ::ChannelId -> UserId -> ChannelRequest () -- | Leave a thread - LeaveThread :: ChannelId -> ChannelRequest () + LeaveThread ::ChannelId -> ChannelRequest () -- | Remove a thread member - RemoveThreadMember :: ChannelId -> UserId -> ChannelRequest () + RemoveThreadMember ::ChannelId -> UserId -> ChannelRequest () -- | Get a thread member - GetThreadMember :: ChannelId -> UserId -> ChannelRequest ThreadMember + GetThreadMember ::ChannelId -> UserId -> ChannelRequest ThreadMember -- | List the thread members - ListThreadMembers :: ChannelId -> ChannelRequest [ThreadMember] + ListThreadMembers ::ChannelId -> ChannelRequest [ThreadMember] -- | List public archived threads in the given channel. Optionally before a -- given time, and optional maximum number of threads. Returns the threads, -- thread members, and whether there are more to collect. -- Requires the READ_MESSAGE_HISTORY permission. - ListPublicArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + ListPublicArchivedThreads ::ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads -- | List private archived threads in the given channel. Optionally before a -- given time, and optional maximum number of threads. Returns the threads, -- thread members, and whether there are more to collect. -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. - ListPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + ListPrivateArchivedThreads ::ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads -- | List joined private archived threads in the given channel. Optionally -- before a given time, and optional maximum number of threads. Returns the -- threads, thread members, and whether there are more to collect. -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. - ListJoinedPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + ListJoinedPrivateArchivedThreads ::ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads -- | Data constructor for CreateMessageDetailed requests. data MessageDetailedOpts = MessageDetailedOpts - { messageDetailedContent :: T.Text - , messageDetailedTTS :: Bool - , messageDetailedEmbeds :: Maybe [CreateEmbed] - , messageDetailedFile :: Maybe (T.Text, B.ByteString) - , messageDetailedAllowedMentions :: Maybe AllowedMentions - , messageDetailedReference :: Maybe MessageReference - , messageDetailedComponents :: Maybe [ComponentActionRow] - , messageDetailedStickerIds :: Maybe [StickerId] - } deriving (Show, Read, Eq, Ord) + { messageDetailedContent :: T.Text + , messageDetailedTTS :: Bool + , messageDetailedEmbeds :: Maybe [CreateEmbed] + , messageDetailedFile :: Maybe (T.Text, B.ByteString) + , messageDetailedAllowedMentions :: Maybe AllowedMentions + , messageDetailedReference :: Maybe MessageReference + , messageDetailedComponents :: Maybe [ComponentActionRow] + , messageDetailedStickerIds :: Maybe [StickerId] + } + deriving (Show, Read, Eq, Ord) instance Default MessageDetailedOpts where def = MessageDetailedOpts { messageDetailedContent = "" @@ -161,8 +167,8 @@ data ReactionTiming = BeforeReaction MessageId reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https reactionTimingToQuery t = case t of (BeforeReaction snow) -> "before" R.=: show snow - (AfterReaction snow) -> "after" R.=: show snow - (LatestReaction) -> mempty + (AfterReaction snow) -> "after" R.=: show snow + LatestReaction -> mempty -- | Data constructor for GetChannelMessages requests. See data MessageTiming = AroundMessage MessageId @@ -175,22 +181,27 @@ messageTimingToQuery :: MessageTiming -> R.Option 'R.Https messageTimingToQuery t = case t of (AroundMessage snow) -> "around" R.=: show snow (BeforeMessage snow) -> "before" R.=: show snow - (AfterMessage snow) -> "after" R.=: show snow - (LatestMessages) -> mempty + (AfterMessage snow) -> "after" R.=: show snow + LatestMessages -> mempty data ChannelInviteOpts = ChannelInviteOpts { channelInviteOptsMaxAgeSeconds :: Maybe Integer , channelInviteOptsMaxUsages :: Maybe Integer , channelInviteOptsIsTemporary :: Maybe Bool , channelInviteOptsDontReuseSimilarInvite :: Maybe Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON ChannelInviteOpts where - toJSON ChannelInviteOpts{..} = object [(name, val) | (name, Just val) <- - [("max_age", toJSON <$> channelInviteOptsMaxAgeSeconds), - ("max_uses", toJSON <$> channelInviteOptsMaxUsages), - ("temporary", toJSON <$> channelInviteOptsIsTemporary), - ("unique", toJSON <$> channelInviteOptsDontReuseSimilarInvite) ] ] + toJSON ChannelInviteOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("max_age" , toJSON <$> channelInviteOptsMaxAgeSeconds) + , ("max_uses" , toJSON <$> channelInviteOptsMaxUsages) + , ("temporary", toJSON <$> channelInviteOptsIsTemporary) + , ("unique" , toJSON <$> channelInviteOptsDontReuseSimilarInvite) + ] + ] data ModifyChannelOpts = ModifyChannelOpts { modifyChannelName :: Maybe T.Text @@ -206,343 +217,408 @@ data ModifyChannelOpts = ModifyChannelOpts , modifyChannelThreadAutoArchive :: Maybe Integer , modifyChannelThreadLocked :: Maybe Bool , modifyChannelThreadInvitiable :: Maybe Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance Default ModifyChannelOpts where - def = ModifyChannelOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + def = ModifyChannelOpts Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing instance ToJSON ModifyChannelOpts where - toJSON ModifyChannelOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> modifyChannelName), - ("position", toJSON <$> modifyChannelPosition), - ("topic", toJSON <$> modifyChannelTopic), - ("nsfw", toJSON <$> modifyChannelNSFW), - ("bitrate", toJSON <$> modifyChannelBitrate), - ("user_limit", toJSON <$> modifyChannelUserRateLimit), - ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites), - ("parent_id", toJSON <$> modifyChannelParentId), - ("default_auto_archive_duration", toJSON <$> modifyChannelDefaultAutoArchive), - ("archived", toJSON <$> modifyChannelThreadArchived), - ("auto_archive_duration", toJSON <$> modifyChannelThreadAutoArchive), - ("locked", toJSON <$> modifyChannelThreadLocked), - ("invitable", toJSON <$> modifyChannelThreadInvitiable) ] ] + toJSON ModifyChannelOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("name" , toJSON <$> modifyChannelName) + , ("position" , toJSON <$> modifyChannelPosition) + , ("topic" , toJSON <$> modifyChannelTopic) + , ("nsfw" , toJSON <$> modifyChannelNSFW) + , ("bitrate" , toJSON <$> modifyChannelBitrate) + , ("user_limit" , toJSON <$> modifyChannelUserRateLimit) + , ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites) + , ("parent_id" , toJSON <$> modifyChannelParentId) + , ( "default_auto_archive_duration" + , toJSON <$> modifyChannelDefaultAutoArchive + ) + , ("archived" , toJSON <$> modifyChannelThreadArchived) + , ("auto_archive_duration", toJSON <$> modifyChannelThreadAutoArchive) + , ("locked" , toJSON <$> modifyChannelThreadLocked) + , ("invitable" , toJSON <$> modifyChannelThreadInvitiable) + ] + ] data ChannelPermissionsOpts = ChannelPermissionsOpts { channelPermissionsOptsAllow :: Integer - , channelPermissionsOptsDeny :: Integer - , channelPermissionsOptsType :: ChannelPermissionsOptsType - } deriving (Show, Read, Eq, Ord) + , channelPermissionsOptsDeny :: Integer + , channelPermissionsOptsType :: ChannelPermissionsOptsType + } + deriving (Show, Read, Eq, Ord) data ChannelPermissionsOptsType = ChannelPermissionsOptsUser | ChannelPermissionsOptsRole deriving (Show, Read, Eq, Ord) instance ToJSON ChannelPermissionsOptsType where - toJSON t = case t of ChannelPermissionsOptsUser -> String "member" - ChannelPermissionsOptsRole -> String "role" + toJSON t = case t of + ChannelPermissionsOptsUser -> String "member" + ChannelPermissionsOptsRole -> String "role" instance ToJSON ChannelPermissionsOpts where - toJSON (ChannelPermissionsOpts a d t) = object [ ("allow", toJSON a ) - , ("deny", toJSON d) - , ("type", toJSON t)] + toJSON (ChannelPermissionsOpts a d t) = + object [("allow", toJSON a), ("deny", toJSON d), ("type", toJSON t)] -- | https://discord.com/developers/docs/resources/channel#group-dm-add-recipient data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts - { groupDMAddRecipientUserToAdd :: UserId - , groupDMAddRecipientUserToAddNickName :: T.Text + { groupDMAddRecipientUserToAdd :: UserId + , groupDMAddRecipientUserToAddNickName :: T.Text , groupDMAddRecipientGDMJoinAccessToken :: T.Text - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) -data StartThreadOpts = StartThreadOpts - { startThreadName :: T.Text +data StartThreadOpts = StartThreadOpts + { startThreadName :: T.Text , startThreadAutoArchive :: Maybe Integer -- ^ can be one of 60, 1440, 4320, 10080 - , startThreadRateLimit :: Maybe Integer - } deriving (Show, Read, Eq, Ord) + , startThreadRateLimit :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) instance ToJSON StartThreadOpts where - toJSON StartThreadOpts{..} = object [ (name, value) | (name, Just value) <- - [ ("name", toJSON <$> pure startThreadName) + toJSON StartThreadOpts {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name" , pure (toJSON startThreadName)) , ("auto_archive_duration", toJSON <$> startThreadAutoArchive) - , ("rate_limit_per_user", toJSON <$> startThreadRateLimit) + , ("rate_limit_per_user" , toJSON <$> startThreadRateLimit) ] ] data StartThreadNoMessageOpts = StartThreadNoMessageOpts - { startThreadNoMessageBaseOpts :: StartThreadOpts - , startThreadNoMessageType :: Integer -- ^ 10, 11, or 12 (https://discord.com/developers/docs/resources/channel#channel-object-channel-types) + { startThreadNoMessageBaseOpts :: StartThreadOpts + , startThreadNoMessageType :: Integer -- ^ 10, 11, or 12 (https://discord.com/developers/docs/resources/channel#channel-object-channel-types) , startThreadNoMessageInvitable :: Maybe Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON StartThreadNoMessageOpts where - toJSON StartThreadNoMessageOpts{..} = object [ (name, value) | (name, Just value) <- - [ ("name", toJSON <$> pure (startThreadName startThreadNoMessageBaseOpts)) - , ("auto_archive_duration", toJSON <$> (startThreadAutoArchive startThreadNoMessageBaseOpts)) - , ("rate_limit_per_user", toJSON <$> (startThreadRateLimit startThreadNoMessageBaseOpts)) - , ("type", toJSON <$> pure startThreadNoMessageType) + toJSON StartThreadNoMessageOpts {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name", pure (toJSON (startThreadName startThreadNoMessageBaseOpts))) + , ( "auto_archive_duration" + , toJSON <$> startThreadAutoArchive startThreadNoMessageBaseOpts + ) + , ( "rate_limit_per_user" + , toJSON <$> startThreadRateLimit startThreadNoMessageBaseOpts + ) + , ("type" , pure (toJSON startThreadNoMessageType)) , ("invitable", toJSON <$> startThreadNoMessageInvitable) ] ] -data ListThreads = ListThreads +data ListThreads = ListThreads { listThreadsThreads :: [Channel] , listThreadsMembers :: [ThreadMember] , listThreadsHasMore :: Bool -- ^ whether there is more data to retrieve - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON ListThreads where - toJSON ListThreads{..} = object - [ ("threads", toJSON listThreadsThreads) - , ("members", toJSON listThreadsMembers) + toJSON ListThreads {..} = object + [ ("threads" , toJSON listThreadsThreads) + , ("members" , toJSON listThreadsMembers) , ("has_more", toJSON listThreadsHasMore) ] instance FromJSON ListThreads where parseJSON = withObject "ListThreads" $ \o -> - ListThreads <$> o .: "threads" - <*> o .: "members" - <*> o .: "has_more" + ListThreads <$> o .: "threads" <*> o .: "members" <*> o .: "has_more" channelMajorRoute :: ChannelRequest a -> String channelMajorRoute c = case c of - (GetChannel chan) -> "get_chan " <> show chan - (ModifyChannel chan _) -> "mod_chan " <> show chan - (DeleteChannel chan) -> "mod_chan " <> show chan - (GetChannelMessages chan _) -> "msg " <> show chan - (GetChannelMessage (chan, _)) -> "get_msg " <> show chan - (CreateMessage chan _) -> "msg " <> show chan - (CreateMessageDetailed chan _) -> "msg " <> show chan - (CreateReaction (chan, _) _) -> "add_react " <> show chan - (DeleteOwnReaction (chan, _) _) -> "react " <> show chan - (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan - (DeleteSingleReaction (chan, _) _) -> "react " <> show chan - (GetReactions (chan, _) _ _) -> "react " <> show chan - (DeleteAllReactions (chan, _)) -> "react " <> show chan - (EditMessage (chan, _) _) -> "get_msg " <> show chan - (DeleteMessage (chan, _)) -> "get_msg " <> show chan - (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan - (EditChannelPermissions chan _ _) -> "perms " <> show chan - (GetChannelInvites chan) -> "invites " <> show chan - (CreateChannelInvite chan _) -> "invites " <> show chan - (DeleteChannelPermission chan _) -> "perms " <> show chan - (TriggerTypingIndicator chan) -> "tti " <> show chan - (GetPinnedMessages chan) -> "pins " <> show chan - (AddPinnedMessage (chan, _)) -> "pin " <> show chan - (DeletePinnedMessage (chan, _)) -> "pin " <> show chan - (GroupDMAddRecipient chan _) -> "groupdm " <> show chan - (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan - (StartThreadFromMessage chan _ _) -> "thread " <> show chan - (StartThreadNoMessage chan _) -> "thread " <> show chan - (JoinThread chan) -> "thread " <> show chan - (AddThreadMember chan _) -> "thread " <> show chan - (LeaveThread chan) -> "thread " <> show chan - (RemoveThreadMember chan _) -> "thread " <> show chan - (GetThreadMember chan _) -> "thread " <> show chan - (ListThreadMembers chan) -> "thread " <> show chan - (ListPublicArchivedThreads chan _) -> "thread " <> show chan - (ListPrivateArchivedThreads chan _) -> "thread " <> show chan + (GetChannel chan ) -> "get_chan " <> show chan + (ModifyChannel chan _ ) -> "mod_chan " <> show chan + (DeleteChannel chan ) -> "mod_chan " <> show chan + (GetChannelMessages chan _ ) -> "msg " <> show chan + (GetChannelMessage (chan, _) ) -> "get_msg " <> show chan + (CreateMessage chan _ ) -> "msg " <> show chan + (CreateMessageDetailed chan _ ) -> "msg " <> show chan + (CreateReaction (chan, _) _ ) -> "add_react " <> show chan + (DeleteOwnReaction (chan, _) _ ) -> "react " <> show chan + (DeleteUserReaction (chan, _) _ _ ) -> "react " <> show chan + (DeleteSingleReaction (chan, _) _ ) -> "react " <> show chan + (GetReactions (chan, _) _ _ ) -> "react " <> show chan + (DeleteAllReactions (chan, _) ) -> "react " <> show chan + (EditMessage (chan, _) _ ) -> "get_msg " <> show chan + (DeleteMessage (chan, _) ) -> "get_msg " <> show chan + (BulkDeleteMessage (chan, _) ) -> "del_msgs " <> show chan + (EditChannelPermissions chan _ _ ) -> "perms " <> show chan + (GetChannelInvites chan ) -> "invites " <> show chan + (CreateChannelInvite chan _ ) -> "invites " <> show chan + (DeleteChannelPermission chan _ ) -> "perms " <> show chan + (TriggerTypingIndicator chan ) -> "tti " <> show chan + (GetPinnedMessages chan ) -> "pins " <> show chan + (AddPinnedMessage (chan, _) ) -> "pin " <> show chan + (DeletePinnedMessage (chan, _) ) -> "pin " <> show chan + (GroupDMAddRecipient chan _ ) -> "groupdm " <> show chan + (GroupDMRemoveRecipient chan _ ) -> "groupdm " <> show chan + (StartThreadFromMessage chan _ _ ) -> "thread " <> show chan + (StartThreadNoMessage chan _ ) -> "thread " <> show chan + (JoinThread chan ) -> "thread " <> show chan + (AddThreadMember chan _ ) -> "thread " <> show chan + (LeaveThread chan ) -> "thread " <> show chan + (RemoveThreadMember chan _ ) -> "thread " <> show chan + (GetThreadMember chan _ ) -> "thread " <> show chan + (ListThreadMembers chan ) -> "thread " <> show chan + (ListPublicArchivedThreads chan _) -> "thread " <> show chan + (ListPrivateArchivedThreads chan _) -> "thread " <> show chan (ListJoinedPrivateArchivedThreads chan _) -> "thread " <> show chan cleanupEmoji :: T.Text -> T.Text cleanupEmoji emoji = let noAngles = T.replace "<" "" (T.replace ">" "" emoji) - byName = T.pack <$> unicodeByName (T.unpack (T.replace ":" "" emoji)) - in case (byName, T.stripPrefix ":" noAngles) of - (Just e, _) -> e - (_, Just a) -> "custom:" <> a - (_, Nothing) -> noAngles + byName = T.pack <$> unicodeByName (T.unpack (T.replace ":" "" emoji)) + in case (byName, T.stripPrefix ":" noAngles) of + (Just e, _ ) -> e + (_ , Just a ) -> "custom:" <> a + (_ , Nothing) -> noAngles channels :: R.Url 'R.Https channels = baseUrl /: "channels" channelJsonRequest :: ChannelRequest r -> JsonRequest channelJsonRequest c = case c of - (GetChannel chan) -> - Get (channels // chan) mempty + (GetChannel chan) -> Get (channels // chan) mempty (ModifyChannel chan patch) -> - Patch (channels // chan) (pure (R.ReqBodyJson patch)) mempty + Patch (channels // chan) (pure (R.ReqBodyJson patch)) mempty - (DeleteChannel chan) -> - Delete (channels // chan) mempty + (DeleteChannel chan) -> Delete (channels // chan) mempty - (GetChannelMessages chan (n,timing)) -> - let n' = max 1 (min 100 n) - options = "limit" R.=: n' <> messageTimingToQuery timing - in Get (channels // chan /: "messages") options + (GetChannelMessages chan (n, timing)) -> + let n' = max 1 (min 100 n) + options = "limit" R.=: n' <> messageTimingToQuery timing + in Get (channels // chan /: "messages") options (GetChannelMessage (chan, msg)) -> - Get (channels // chan /: "messages" // msg) mempty + Get (channels // chan /: "messages" // msg) mempty (CreateMessage chan msg) -> - let content = ["content" .= msg] - body = pure $ R.ReqBodyJson $ object content - in Post (channels // chan /: "messages") body mempty + let content = ["content" .= msg] + body = pure $ R.ReqBodyJson $ object content + in Post (channels // chan /: "messages") body mempty (CreateMessageDetailed chan msgOpts) -> - let fileUpload = messageDetailedFile msgOpts - filePart = - ( case fileUpload of - Nothing -> [] - Just f -> - [ partFileRequestBody - "file" - (T.unpack $ fst f) - (RequestBodyBS $ snd f) - ] + let + fileUpload = messageDetailedFile msgOpts + filePart = + (case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] ) - ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) - - payloadData = object $ [ "content" .= messageDetailedContent msgOpts - , "tts" .= messageDetailedTTS msgOpts ] ++ - [ name .= value | (name, Just value) <- - [ ("embeds", toJSON . (createEmbed <$>) <$> messageDetailedEmbeds msgOpts) - , ("allowed_mentions", toJSON <$> messageDetailedAllowedMentions msgOpts) - , ("message_reference", toJSON <$> messageDetailedReference msgOpts) - , ("components", toJSON <$> messageDetailedComponents msgOpts) - , ("sticker_ids", toJSON <$> messageDetailedStickerIds msgOpts) - ] ] - payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData - - body = R.reqBodyMultipart (payloadPart : filePart) - in Post (channels // chan /: "messages") body mempty + ++ join + (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts) + ) + + payloadData = + object + $ [ "content" .= messageDetailedContent msgOpts + , "tts" .= messageDetailedTTS msgOpts + ] + ++ [ name .= value + | (name, Just value) <- + [ ( "embeds" + , toJSON . (createEmbed <$>) <$> messageDetailedEmbeds msgOpts + ) + , ( "allowed_mentions" + , toJSON <$> messageDetailedAllowedMentions msgOpts + ) + , ( "message_reference" + , toJSON <$> messageDetailedReference msgOpts + ) + , ("components" , toJSON <$> messageDetailedComponents msgOpts) + , ("sticker_ids", toJSON <$> messageDetailedStickerIds msgOpts) + ] + ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) + in + Post (channels // chan /: "messages") body mempty (CreateReaction (chan, msgid) emoji) -> - let e = cleanupEmoji emoji - in Put (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me" ) - R.NoReqBody mempty + let e = cleanupEmoji emoji + in Put + (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me") + R.NoReqBody + mempty (DeleteOwnReaction (chan, msgid) emoji) -> - let e = cleanupEmoji emoji - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me" ) mempty + let e = cleanupEmoji emoji + in Delete + (channels // chan /: "messages" // msgid /: "reactions" /: e /: "@me") + mempty (DeleteUserReaction (chan, msgid) uID emoji) -> - let e = cleanupEmoji emoji - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e // uID ) mempty + let e = cleanupEmoji emoji + in Delete + (channels // chan /: "messages" // msgid /: "reactions" /: e // uID) + mempty (DeleteSingleReaction (chan, msgid) emoji) -> let e = cleanupEmoji emoji - in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e) mempty + in Delete (channels // chan /: "messages" // msgid /: "reactions" /: e) + mempty (GetReactions (chan, msgid) emoji (n, timing)) -> - let e = cleanupEmoji emoji - n' = max 1 (min 100 n) - options = "limit" R.=: n' <> reactionTimingToQuery timing - in Get (channels // chan /: "messages" // msgid /: "reactions" /: e) options + let e = cleanupEmoji emoji + n' = max 1 (min 100 n) + options = "limit" R.=: n' <> reactionTimingToQuery timing + in Get (channels // chan /: "messages" // msgid /: "reactions" /: e) + options (DeleteAllReactions (chan, msgid)) -> - Delete (channels // chan /: "messages" // msgid /: "reactions" ) mempty + Delete (channels // chan /: "messages" // msgid /: "reactions") mempty -- copied from CreateMessageDetailed, should be outsourced to function probably - (EditMessage (chan, msg) msgOpts) -> - let fileUpload = messageDetailedFile msgOpts - filePart = - ( case fileUpload of - Nothing -> [] - Just f -> - [ partFileRequestBody - "file" - (T.unpack $ fst f) - (RequestBodyBS $ snd f) - ] + (EditMessage (chan, msg) msgOpts) -> + let + fileUpload = messageDetailedFile msgOpts + filePart = + (case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] ) - ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) - - payloadData = object $ [ "content" .= messageDetailedContent msgOpts - , "tts" .= messageDetailedTTS msgOpts ] ++ - [ name .= value | (name, Just value) <- - [ ("embeds", toJSON . (createEmbed <$>) <$> messageDetailedEmbeds msgOpts) - , ("allowed_mentions", toJSON <$> messageDetailedAllowedMentions msgOpts) - , ("message_reference", toJSON <$> messageDetailedReference msgOpts) - , ("components", toJSON <$> messageDetailedComponents msgOpts) - , ("sticker_ids", toJSON <$> messageDetailedStickerIds msgOpts) - ] ] - payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData - - body = R.reqBodyMultipart (payloadPart : filePart) - in Patch (channels // chan /: "messages" // msg) body mempty + ++ join + (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts) + ) + + payloadData = + object + $ [ "content" .= messageDetailedContent msgOpts + , "tts" .= messageDetailedTTS msgOpts + ] + ++ [ name .= value + | (name, Just value) <- + [ ( "embeds" + , toJSON . (createEmbed <$>) <$> messageDetailedEmbeds msgOpts + ) + , ( "allowed_mentions" + , toJSON <$> messageDetailedAllowedMentions msgOpts + ) + , ( "message_reference" + , toJSON <$> messageDetailedReference msgOpts + ) + , ("components" , toJSON <$> messageDetailedComponents msgOpts) + , ("sticker_ids", toJSON <$> messageDetailedStickerIds msgOpts) + ] + ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) + in + Patch (channels // chan /: "messages" // msg) body mempty (DeleteMessage (chan, msg)) -> - Delete (channels // chan /: "messages" // msg) mempty + Delete (channels // chan /: "messages" // msg) mempty (BulkDeleteMessage (chan, msgs)) -> - let body = pure . R.ReqBodyJson $ object ["messages" .= msgs] - in Post (channels // chan /: "messages" /: "bulk-delete") body mempty + let body = pure . R.ReqBodyJson $ object ["messages" .= msgs] + in Post (channels // chan /: "messages" /: "bulk-delete") body mempty - (EditChannelPermissions chan perm patch) -> - Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty + (EditChannelPermissions chan perm patch) -> Put + (channels // chan /: "permissions" // perm) + (R.ReqBodyJson patch) + mempty - (GetChannelInvites chan) -> - Get (channels // chan /: "invites") mempty + (GetChannelInvites chan) -> Get (channels // chan /: "invites") mempty (CreateChannelInvite chan patch) -> - Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty + Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty (DeleteChannelPermission chan perm) -> - Delete (channels // chan /: "permissions" // perm) mempty + Delete (channels // chan /: "permissions" // perm) mempty (TriggerTypingIndicator chan) -> - Post (channels // chan /: "typing") (pure R.NoReqBody) mempty + Post (channels // chan /: "typing") (pure R.NoReqBody) mempty - (GetPinnedMessages chan) -> - Get (channels // chan /: "pins") mempty + (GetPinnedMessages chan) -> Get (channels // chan /: "pins") mempty (AddPinnedMessage (chan, msg)) -> - Put (channels // chan /: "pins" // msg) R.NoReqBody mempty + Put (channels // chan /: "pins" // msg) R.NoReqBody mempty (DeletePinnedMessage (chan, msg)) -> - Delete (channels // chan /: "pins" // msg) mempty + Delete (channels // chan /: "pins" // msg) mempty - (GroupDMAddRecipient chan (GroupDMAddRecipientOpts uid nick tok)) -> - Put (channels // chan // chan /: "recipients" // uid) - (R.ReqBodyJson (object [ ("access_token", toJSON tok) - , ("nick", toJSON nick)])) - mempty + (GroupDMAddRecipient chan (GroupDMAddRecipientOpts uid nick tok)) -> Put + (channels // chan // chan /: "recipients" // uid) + (R.ReqBodyJson + (object [("access_token", toJSON tok), ("nick", toJSON nick)]) + ) + mempty (GroupDMRemoveRecipient chan userid) -> - Delete (channels // chan // chan /: "recipients" // userid) mempty + Delete (channels // chan // chan /: "recipients" // userid) mempty - (StartThreadFromMessage chan mid sto) -> - Post (channels // chan /: "messages" // mid /: "threads") - (pure $ R.ReqBodyJson $ toJSON sto) - mempty + (StartThreadFromMessage chan mid sto) -> Post + (channels // chan /: "messages" // mid /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty - (StartThreadNoMessage chan sto) -> - Post (channels // chan /: "messages" /: "threads") - (pure $ R.ReqBodyJson $ toJSON sto) - mempty + (StartThreadNoMessage chan sto) -> Post + (channels // chan /: "messages" /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty (JoinThread chan) -> - Put (channels // chan /: "thread-members" /: "@me") - R.NoReqBody mempty + Put (channels // chan /: "thread-members" /: "@me") R.NoReqBody mempty (AddThreadMember chan uid) -> - Put (channels // chan /: "thread-members" // uid) - R.NoReqBody mempty + Put (channels // chan /: "thread-members" // uid) R.NoReqBody mempty (LeaveThread chan) -> - Delete (channels // chan /: "thread-members" /: "@me") - mempty + Delete (channels // chan /: "thread-members" /: "@me") mempty (RemoveThreadMember chan uid) -> - Delete (channels // chan /: "thread-members" // uid) - mempty + Delete (channels // chan /: "thread-members" // uid) mempty (GetThreadMember chan uid) -> - Get (channels // chan /: "thread-members" // uid) - mempty - - (ListThreadMembers chan) -> - Get (channels // chan /: "thread-members") - mempty - - (ListPublicArchivedThreads chan (time, lim)) -> - Get (channels // chan /: "threads" /: "archived" /: "public") - (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) - - (ListPrivateArchivedThreads chan (time, lim)) -> - Get (channels // chan /: "threads" /: "archived" /: "private") - (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) - - (ListJoinedPrivateArchivedThreads chan (time, lim)) -> - Get (channels // chan /: "users" /: "@me" /: "threads" /: "archived" /: "private") - (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + Get (channels // chan /: "thread-members" // uid) mempty + + (ListThreadMembers chan) -> Get (channels // chan /: "thread-members") mempty + + (ListPublicArchivedThreads chan (time, lim)) -> Get + (channels // chan /: "threads" /: "archived" /: "public") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListPrivateArchivedThreads chan (time, lim)) -> Get + (channels // chan /: "threads" /: "archived" /: "private") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListJoinedPrivateArchivedThreads chan (time, lim)) -> Get + ( channels + // chan + /: "users" + /: "@me" + /: "threads" + /: "archived" + /: "private" + ) + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) diff --git a/src/Discord/Internal/Rest/Emoji.hs b/src/Discord/Internal/Rest/Emoji.hs index 7e5fbff8..8ec92b96 100644 --- a/src/Discord/Internal/Rest/Emoji.hs +++ b/src/Discord/Internal/Rest/Emoji.hs @@ -6,46 +6,45 @@ -- | Provides actions for Channel API interactions module Discord.Internal.Rest.Emoji - ( EmojiRequest (..), - ModifyGuildEmojiOpts (..), - parseEmojiImage, - StickerRequest (..), - CreateGuildStickerOpts (..), - EditGuildStickerOpts (..) - ) -where - -import Codec.Picture -import Data.Aeson -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64 as B64 -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R + ( EmojiRequest(..) + , ModifyGuildEmojiOpts(..) + , parseEmojiImage + , StickerRequest(..) + , CreateGuildStickerOpts(..) + , EditGuildStickerOpts(..) + ) where + +import Codec.Picture +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R instance Request (EmojiRequest a) where - majorRoute = emojiMajorRoute + majorRoute = emojiMajorRoute jsonRequest = emojiJsonRequest -- | Data constructor for requests. See data EmojiRequest a where -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission. - ListGuildEmojis :: GuildId -> EmojiRequest [Emoji] + ListGuildEmojis ::GuildId -> EmojiRequest [Emoji] -- | Emoji object for the given guild and emoji ID - GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji + GetGuildEmoji ::GuildId -> EmojiId -> EmojiRequest Emoji -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission. - CreateGuildEmoji :: GuildId -> T.Text -> EmojiImageParsed -> EmojiRequest Emoji + CreateGuildEmoji ::GuildId -> T.Text -> EmojiImageParsed -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission - ModifyGuildEmoji :: GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji + ModifyGuildEmoji ::GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji -- | Requires MANAGE_EMOJIS permission - DeleteGuildEmoji :: GuildId -> EmojiId -> EmojiRequest () + DeleteGuildEmoji ::GuildId -> EmojiId -> EmojiRequest () data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts - { modifyGuildEmojiName :: T.Text, - modifyGuildEmojiRoles :: [RoleId] + { modifyGuildEmojiName :: T.Text + , modifyGuildEmojiRoles :: [RoleId] } deriving (Show, Read, Eq, Ord) @@ -57,50 +56,34 @@ newtype EmojiImageParsed = EmojiImageParsed T.Text deriving (Show, Read, Eq, Ord) parseEmojiImage :: B.ByteString -> Either T.Text EmojiImageParsed -parseEmojiImage bs = - if B.length bs > 256000 - then Left "Cannot create emoji - File is larger than 256kb" - else case (decodeGifImages bs, decodeImage bs) of - (Left e1, Left e2) -> - Left - ( "Could not parse image or gif: " <> T.pack e1 - <> " and " - <> T.pack e2 - ) - (Right ims, _) -> - if all is128 ims - then - Right - ( EmojiImageParsed - ( "data:text/plain;" - <> "base64," - <> TE.decodeUtf8 (B64.encode bs) - ) - ) - else Left "The frames are not all 128x128" - (_, Right im) -> - if is128 im - then - Right - ( EmojiImageParsed - ( "data:text/plain;" - <> "base64," - <> TE.decodeUtf8 (B64.encode bs) - ) - ) - else Left "Image is not 128x128" - where - is128 im = - let i = convertRGB8 im - in imageWidth i == 128 && imageHeight i == 128 +parseEmojiImage bs = if B.length bs > 256000 + then Left "Cannot create emoji - File is larger than 256kb" + else case (decodeGifImages bs, decodeImage bs) of + (Left e1, Left e2) -> Left + ("Could not parse image or gif: " <> T.pack e1 <> " and " <> T.pack e2) + (Right ims, _) -> if all is128 ims + then Right + (EmojiImageParsed + ("data:text/plain;" <> "base64," <> TE.decodeUtf8 (B64.encode bs)) + ) + else Left "The frames are not all 128x128" + (_, Right im) -> if is128 im + then Right + (EmojiImageParsed + ("data:text/plain;" <> "base64," <> TE.decodeUtf8 (B64.encode bs)) + ) + else Left "Image is not 128x128" + where + is128 im = + let i = convertRGB8 im in imageWidth i == 128 && imageHeight i == 128 emojiMajorRoute :: EmojiRequest a -> String emojiMajorRoute c = case c of - (ListGuildEmojis g) -> "emoji " <> show g - (GetGuildEmoji g _) -> "emoji " <> show g + (ListGuildEmojis g ) -> "emoji " <> show g + (GetGuildEmoji g _ ) -> "emoji " <> show g (CreateGuildEmoji g _ _) -> "emoji " <> show g (ModifyGuildEmoji g _ _) -> "emoji " <> show g - (DeleteGuildEmoji g _) -> "emoji " <> show g + (DeleteGuildEmoji g _ ) -> "emoji " <> show g guilds :: R.Url 'R.Https guilds = baseUrl /: "guilds" @@ -109,75 +92,70 @@ emojiJsonRequest :: EmojiRequest r -> JsonRequest emojiJsonRequest c = case c of (ListGuildEmojis g) -> Get (guilds // g /: "emojis") mempty (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty - (CreateGuildEmoji g name (EmojiImageParsed im)) -> - Post - (guilds // g /: "emojis") - ( pure - ( R.ReqBodyJson - ( object - [ "name" .= name, - "image" .= im + (CreateGuildEmoji g name (EmojiImageParsed im)) -> Post + (guilds // g /: "emojis") + (pure + (R.ReqBodyJson + (object + [ "name" .= name + , "image" .= im -- todo , "roles" .= ... - ] - ) - ) + ] + ) ) - mempty + ) + mempty (ModifyGuildEmoji g e o) -> - Patch - (guilds // g /: "emojis" // e) - (pure (R.ReqBodyJson o)) - mempty + Patch (guilds // g /: "emojis" // e) (pure (R.ReqBodyJson o)) mempty (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty data StickerData = StickerDataPNG {stickerData :: B.ByteString} | StickerDataAPNG {stickerData :: B.ByteString} | StickerDataLOTTIE {stickerData :: B.ByteString} deriving (Show, Read, Eq, Ord) instance ToJSON StickerData where - toJSON sd = String $ "data:image/" <> sdt <> ";base64," <> TE.decodeUtf8 (B64.encode (stickerData sd)) - where - sdt = case sd of - StickerDataPNG _ -> "png" - StickerDataAPNG _ -> "apng" - StickerDataLOTTIE _ -> "lottie" + toJSON sd = String $ "data:image/" <> sdt <> ";base64," <> TE.decodeUtf8 + (B64.encode (stickerData sd)) + where + sdt = case sd of + StickerDataPNG _ -> "png" + StickerDataAPNG _ -> "apng" + StickerDataLOTTIE _ -> "lottie" data CreateGuildStickerOpts = CreateGuildStickerOpts - { guildStickerName :: T.Text, - guildStickerDescription :: T.Text, - guildStickerTags :: [T.Text], - guildStickerFile :: StickerData + { guildStickerName :: T.Text + , guildStickerDescription :: T.Text + , guildStickerTags :: [T.Text] + , guildStickerFile :: StickerData } deriving (Show, Read, Eq, Ord) instance ToJSON CreateGuildStickerOpts where - toJSON CreateGuildStickerOpts {..} = - object - [ ("name", toJSON guildStickerName), - ("description", toJSON guildStickerDescription), - ("tags", toJSON . T.intercalate "," $ guildStickerTags), - ("file", toJSON guildStickerFile) - ] + toJSON CreateGuildStickerOpts {..} = object + [ ("name" , toJSON guildStickerName) + , ("description", toJSON guildStickerDescription) + , ("tags" , toJSON . T.intercalate "," $ guildStickerTags) + , ("file" , toJSON guildStickerFile) + ] data EditGuildStickerOpts = EditGuildStickerOpts - { editGuildStickerName :: Maybe T.Text, - editGuildStickerDescription :: Maybe T.Text, - editGuildStickerTags :: Maybe [T.Text] + { editGuildStickerName :: Maybe T.Text + , editGuildStickerDescription :: Maybe T.Text + , editGuildStickerTags :: Maybe [T.Text] } deriving (Show, Read, Eq, Ord) instance ToJSON EditGuildStickerOpts where - toJSON EditGuildStickerOpts {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toJSON <$> editGuildStickerName), - ("description", toJSON <$> editGuildStickerDescription), - ("tags", toJSON . T.intercalate "," <$> editGuildStickerTags) - ] + toJSON EditGuildStickerOpts {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name" , toJSON <$> editGuildStickerName) + , ("description", toJSON <$> editGuildStickerDescription) + , ("tags" , toJSON . T.intercalate "," <$> editGuildStickerTags) ] + ] instance Request (StickerRequest a) where - majorRoute = stickerMajorRoute + majorRoute = stickerMajorRoute jsonRequest = stickerJsonRequest -- | Data constructor for requests. See @@ -186,38 +164,39 @@ instance Request (StickerRequest a) where -- boosts. Functionality is at your own risk. data StickerRequest a where -- | Returns a sticker object for the given sticker ID. - GetSticker :: StickerId -> StickerRequest Sticker + GetSticker ::StickerId -> StickerRequest Sticker -- | Returns the list of sticker packs available to Nitro subscribers. - ListNitroStickerPacks :: StickerRequest [StickerPack] + ListNitroStickerPacks ::StickerRequest [StickerPack] -- | Returns an array of sticker objects for the given guild. - ListGuildStickers :: GuildId -> StickerRequest [Sticker] + ListGuildStickers ::GuildId -> StickerRequest [Sticker] -- | Returns a sticker object for the given guild and sticker ID. - GetGuildSticker :: GuildId -> StickerId -> StickerRequest Sticker + GetGuildSticker ::GuildId -> StickerId -> StickerRequest Sticker -- | Create a new sticker for the guild. - CreateGuildSticker :: GuildId -> CreateGuildStickerOpts -> StickerRequest Sticker + CreateGuildSticker ::GuildId -> CreateGuildStickerOpts -> StickerRequest Sticker -- | Modify a sticker for a guild. - ModifyGuildSticker :: GuildId -> StickerId -> EditGuildStickerOpts -> StickerRequest Sticker + ModifyGuildSticker ::GuildId -> StickerId -> EditGuildStickerOpts -> StickerRequest Sticker -- | Delete a guild sticker - DeleteGuildSticker :: GuildId -> StickerId -> StickerRequest () + DeleteGuildSticker ::GuildId -> StickerId -> StickerRequest () stickerMajorRoute :: StickerRequest a -> String stickerMajorRoute = \case - GetSticker gid -> "sticker " <> show gid - ListNitroStickerPacks -> "sticker" - ListGuildStickers gid -> "sticker " <> show gid - GetGuildSticker gid _ -> "sticker " <> show gid - CreateGuildSticker gid _ -> "sticker " <> show gid + GetSticker gid -> "sticker " <> show gid + ListNitroStickerPacks -> "sticker" + ListGuildStickers gid -> "sticker " <> show gid + GetGuildSticker gid _ -> "sticker " <> show gid + CreateGuildSticker gid _ -> "sticker " <> show gid ModifyGuildSticker gid _ _ -> "sticker " <> show gid - DeleteGuildSticker gid _ -> "sticker " <> show gid + DeleteGuildSticker gid _ -> "sticker " <> show gid stickerJsonRequest :: StickerRequest a -> JsonRequest stickerJsonRequest = \case - GetSticker gid -> Get (baseUrl /: "stickers" // gid) mempty - ListNitroStickerPacks -> Get (baseUrl /: "sticker-packs") mempty - ListGuildStickers gid -> Get (stickersGuild gid) mempty + GetSticker gid -> Get (baseUrl /: "stickers" // gid) mempty + ListNitroStickerPacks -> Get (baseUrl /: "sticker-packs") mempty + ListGuildStickers gid -> Get (stickersGuild gid) mempty GetGuildSticker gid sid -> Get (stickersGuild gid // sid) mempty - CreateGuildSticker gid cgso -> Post (stickersGuild gid) (pure $ R.ReqBodyJson $ toJSON cgso) mempty - ModifyGuildSticker gid sid egso -> Patch (stickersGuild gid // sid) (pure $ R.ReqBodyJson egso) mempty + CreateGuildSticker gid cgso -> + Post (stickersGuild gid) (pure $ R.ReqBodyJson $ toJSON cgso) mempty + ModifyGuildSticker gid sid egso -> + Patch (stickersGuild gid // sid) (pure $ R.ReqBodyJson egso) mempty DeleteGuildSticker gid sid -> Delete (stickersGuild gid // sid) mempty - where - stickersGuild gid = baseUrl /: "guilds" // gid /: "stickers" + where stickersGuild gid = baseUrl /: "guilds" // gid /: "stickers" diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs index 1c603b5c..34968d7e 100644 --- a/src/Discord/Internal/Rest/Guild.hs +++ b/src/Discord/Internal/Rest/Guild.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} + {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,17 +19,17 @@ module Discord.Internal.Rest.Guild ) where -import Data.Aeson -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T +import Data.Aeson +import qualified Data.Text as T +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types -import Data.Default (Default(..)) +import Data.Default ( Default(..) ) +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types instance Request (GuildRequest a) where - majorRoute = guildMajorRoute + majorRoute = guildMajorRoute jsonRequest = guildJsonRequest -- | Data constructor for requests. See @@ -38,139 +38,150 @@ data GuildRequest a where -- -- https://discord.com/developers/docs/resources/guild#create-guild -- | Returns the new 'Guild' object for the given id - GetGuild :: GuildId -> GuildRequest Guild + GetGuild ::GuildId -> GuildRequest Guild -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a -- Guild Update 'Event'. - ModifyGuild :: GuildId -> ModifyGuildOpts -> GuildRequest Guild + ModifyGuild ::GuildId -> ModifyGuildOpts -> GuildRequest Guild -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'. - DeleteGuild :: GuildId -> GuildRequest () + DeleteGuild ::GuildId -> GuildRequest () -- | Returns a list of guild 'Channel' objects - GetGuildChannels :: GuildId -> GuildRequest [Channel] + GetGuildChannels ::GuildId -> GuildRequest [Channel] -- | Create a new 'Channel' object for the guild. Requires 'MANAGE_CHANNELS' -- permission. Returns the new 'Channel' object on success. Fires a Channel Create -- 'Event' - CreateGuildChannel :: GuildId -> T.Text -> [Overwrite] -> CreateGuildChannelOpts -> GuildRequest Channel + CreateGuildChannel ::GuildId -> T.Text -> [Overwrite] -> CreateGuildChannelOpts -> GuildRequest Channel -- | Modify the positions of a set of channel objects for the guild. Requires -- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel' -- objects on success. Fires multiple Channel Update 'Event's. - ModifyGuildChannelPositions :: GuildId -> [(ChannelId,Int)] -> GuildRequest [Channel] + ModifyGuildChannelPositions ::GuildId -> [(ChannelId,Int)] -> GuildRequest [Channel] -- | Returns a guild 'Member' object for the specified user - GetGuildMember :: GuildId -> UserId -> GuildRequest GuildMember + GetGuildMember ::GuildId -> UserId -> GuildRequest GuildMember -- | Returns a list of guild 'Member' objects that are members of the guild. - ListGuildMembers :: GuildId -> GuildMembersTiming -> GuildRequest [GuildMember] + ListGuildMembers ::GuildId -> GuildMembersTiming -> GuildRequest [GuildMember] -- | Adds a user to the guild, provided you have a valid oauth2 access token -- for the user with the guilds.join scope. Returns the guild 'Member' as the body. -- Fires a Guild Member Add 'Event'. Requires the bot to have the -- CREATE_INSTANT_INVITE permission. - AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts + AddGuildMember ::GuildId -> UserId -> AddGuildMemberOpts -> GuildRequest () -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. - ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember + ModifyGuildMember ::GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember -- | Modify the nickname of the current user - ModifyCurrentUserNick :: GuildId -> T.Text -> GuildRequest () + ModifyCurrentUserNick ::GuildId -> T.Text -> GuildRequest () -- | Add a member to a guild role. Requires 'MANAGE_ROLES' permission. - AddGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest () + AddGuildMemberRole ::GuildId -> UserId -> RoleId -> GuildRequest () -- | Remove a member from a guild role. Requires 'MANAGE_ROLES' permission. - RemoveGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest () + RemoveGuildMemberRole ::GuildId -> UserId -> RoleId -> GuildRequest () -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a -- Guild Member Remove 'Event'. - RemoveGuildMember :: GuildId -> UserId -> GuildRequest () + RemoveGuildMember ::GuildId -> UserId -> GuildRequest () -- | Returns a list of 'Ban' objects for users that are banned from this guild. Requires the -- 'BAN_MEMBERS' permission - GetGuildBans :: GuildId -> GuildRequest [GuildBan] + GetGuildBans ::GuildId -> GuildRequest [GuildBan] -- | Returns a 'Ban' object for the user banned from this guild. Requires the -- 'BAN_MEMBERS' permission - GetGuildBan :: GuildId -> UserId -> GuildRequest GuildBan + GetGuildBan ::GuildId -> UserId -> GuildRequest GuildBan -- | Create a guild ban, and optionally Delete previous messages sent by the banned -- user. Requires the 'BAN_MEMBERS' permission. Fires a Guild Ban Add 'Event'. - CreateGuildBan :: GuildId -> UserId -> CreateGuildBanOpts -> GuildRequest () + CreateGuildBan ::GuildId -> UserId -> CreateGuildBanOpts -> GuildRequest () -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions. -- Fires a Guild Ban Remove 'Event'. - RemoveGuildBan :: GuildId -> UserId -> GuildRequest () + RemoveGuildBan ::GuildId -> UserId -> GuildRequest () -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES' -- permission - GetGuildRoles :: GuildId -> GuildRequest [Role] + GetGuildRoles ::GuildId -> GuildRequest [Role] -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission. -- Returns the new role object on success. Fires a Guild Role Create 'Event'. - CreateGuildRole :: GuildId -> ModifyGuildRoleOpts -> GuildRequest Role + CreateGuildRole ::GuildId -> ModifyGuildRoleOpts -> GuildRequest Role -- | Modify the positions of a set of role objects for the guild. Requires the -- 'MANAGE_ROLES' permission. Returns a list of all of the guild's 'Role' objects -- on success. Fires multiple Guild Role Update 'Event's. - ModifyGuildRolePositions :: GuildId -> [(RoleId, Integer)] -> GuildRequest [Role] + ModifyGuildRolePositions ::GuildId -> [(RoleId, Integer)] -> GuildRequest [Role] -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the -- updated 'Role' on success. Fires a Guild Role Update 'Event's. - ModifyGuildRole :: GuildId -> RoleId -> ModifyGuildRoleOpts -> GuildRequest Role + ModifyGuildRole ::GuildId -> RoleId -> ModifyGuildRoleOpts -> GuildRequest Role -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role -- Delete 'Event'. - DeleteGuildRole :: GuildId -> RoleId -> GuildRequest () + DeleteGuildRole ::GuildId -> RoleId -> GuildRequest () -- | Returns an object with one 'pruned' key indicating the number of members -- that would be removed in a prune operation. Requires the 'KICK_MEMBERS' -- permission. - GetGuildPruneCount :: GuildId -> Integer -> GuildRequest Object + GetGuildPruneCount ::GuildId -> Integer -> GuildRequest Object -- | Begin a prune operation. Requires the 'KICK_MEMBERS' permission. Returns an -- object with one 'pruned' key indicating the number of members that were removed -- in the prune operation. Fires multiple Guild Member Remove 'Events'. - BeginGuildPrune :: GuildId -> Integer -> GuildRequest Object + BeginGuildPrune ::GuildId -> Integer -> GuildRequest Object -- | Returns a list of 'VoiceRegion' objects for the guild. Unlike the similar /voice -- route, this returns VIP servers when the guild is VIP-enabled. - GetGuildVoiceRegions :: GuildId -> GuildRequest [VoiceRegion] + GetGuildVoiceRegions ::GuildId -> GuildRequest [VoiceRegion] -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD' -- permission. - GetGuildInvites :: GuildId -> GuildRequest [Invite] + GetGuildInvites ::GuildId -> GuildRequest [Invite] -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD' -- permission. - GetGuildIntegrations :: GuildId -> GuildRequest [Integration] + GetGuildIntegrations ::GuildId -> GuildRequest [Integration] -- | Attach an 'Integration' object from the current user to the guild. Requires the -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. - CreateGuildIntegration :: GuildId -> IntegrationId -> CreateGuildIntegrationOpts -> GuildRequest () + CreateGuildIntegration ::GuildId -> IntegrationId -> CreateGuildIntegrationOpts -> GuildRequest () -- | Modify the behavior and settings of a 'Integration' object for the guild. -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. - ModifyGuildIntegration :: GuildId -> IntegrationId -> ModifyGuildIntegrationOpts + ModifyGuildIntegration ::GuildId -> IntegrationId -> ModifyGuildIntegrationOpts -> GuildRequest () -- | Delete the attached 'Integration' object for the guild. Requires the -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. - DeleteGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () + DeleteGuildIntegration ::GuildId -> IntegrationId -> GuildRequest () -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. - SyncGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () + SyncGuildIntegration ::GuildId -> IntegrationId -> GuildRequest () -- | Returns the 'GuildWidget' object. Requires the 'MANAGE_GUILD' permission. - GetGuildWidget :: GuildId -> GuildRequest GuildWidget + GetGuildWidget ::GuildId -> GuildRequest GuildWidget -- | Modify a 'GuildWidget' object for the guild. All attributes may be passed in with -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated -- 'GuildWidget' object. - ModifyGuildWidget :: GuildId -> GuildWidget -> GuildRequest GuildWidget + ModifyGuildWidget ::GuildId -> GuildWidget -> GuildRequest GuildWidget -- | Vanity URL - GetGuildVanityURL :: GuildId -> GuildRequest T.Text + GetGuildVanityURL ::GuildId -> GuildRequest T.Text data ModifyGuildIntegrationOpts = ModifyGuildIntegrationOpts - { modifyGuildIntegrationOptsExpireBehavior :: Integer + { modifyGuildIntegrationOptsExpireBehavior :: Integer , modifyGuildIntegrationOptsExpireGraceSeconds :: Integer - , modifyGuildIntegrationOptsEmoticonsEnabled :: Bool - } deriving (Show, Read, Eq, Ord) + , modifyGuildIntegrationOptsEmoticonsEnabled :: Bool + } + deriving (Show, Read, Eq, Ord) instance ToJSON ModifyGuildIntegrationOpts where - toJSON ModifyGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- - [ ("expire_grace_period", toJSON <$> pure modifyGuildIntegrationOptsExpireGraceSeconds ) - , ("expire_behavior", toJSON <$> pure modifyGuildIntegrationOptsExpireBehavior ) - , ("enable_emoticons", toJSON <$> pure modifyGuildIntegrationOptsEmoticonsEnabled ) ]] - -data CreateGuildIntegrationOpts = CreateGuildIntegrationOpts + toJSON ModifyGuildIntegrationOpts {..} = object + [ ( "expire_grace_period" + , toJSON modifyGuildIntegrationOptsExpireGraceSeconds + ) + , ("expire_behavior" , toJSON modifyGuildIntegrationOptsExpireBehavior) + , ("enable_emoticons", toJSON modifyGuildIntegrationOptsEmoticonsEnabled) + ] + +newtype CreateGuildIntegrationOpts = CreateGuildIntegrationOpts { createGuildIntegrationOptsType :: T.Text - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON CreateGuildIntegrationOpts where - toJSON CreateGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- - [("type", toJSON <$> pure createGuildIntegrationOptsType ) ]] + toJSON CreateGuildIntegrationOpts {..} = + object [("type", toJSON createGuildIntegrationOptsType)] data CreateGuildBanOpts = CreateGuildBanOpts { createGuildBanOptsDeleteLastNMessages :: Maybe Int , createGuildBanOptsReason :: Maybe T.Text - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON CreateGuildBanOpts where - toJSON CreateGuildBanOpts{..} = object [(name, val) | (name, Just val) <- - [("delete_message_days", - toJSON <$> createGuildBanOptsDeleteLastNMessages ), - ("reason", toJSON <$> createGuildBanOptsReason )]] + toJSON CreateGuildBanOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ( "delete_message_days" + , toJSON <$> createGuildBanOptsDeleteLastNMessages + ) + , ("reason", toJSON <$> createGuildBanOptsReason) + ] + ] data ModifyGuildRoleOpts = ModifyGuildRoleOpts { modifyGuildRoleOptsName :: Maybe T.Text @@ -178,15 +189,20 @@ data ModifyGuildRoleOpts = ModifyGuildRoleOpts , modifyGuildRoleOptsColor :: Maybe DiscordColor , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool , modifyGuildRoleOptsMentionable :: Maybe Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON ModifyGuildRoleOpts where - toJSON ModifyGuildRoleOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> modifyGuildRoleOptsName ), - ("permissions", toJSON <$> modifyGuildRoleOptsPermissions ), - ("color", toJSON <$> modifyGuildRoleOptsColor ), - ("hoist", toJSON <$> modifyGuildRoleOptsSeparateSidebar ), - ("mentionable", toJSON <$> modifyGuildRoleOptsMentionable )]] + toJSON ModifyGuildRoleOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("name" , toJSON <$> modifyGuildRoleOptsName) + , ("permissions", toJSON <$> modifyGuildRoleOptsPermissions) + , ("color" , toJSON <$> modifyGuildRoleOptsColor) + , ("hoist" , toJSON <$> modifyGuildRoleOptsSeparateSidebar) + , ("mentionable", toJSON <$> modifyGuildRoleOptsMentionable) + ] + ] data AddGuildMemberOpts = AddGuildMemberOpts { addGuildMemberOptsAccessToken :: T.Text @@ -194,15 +210,20 @@ data AddGuildMemberOpts = AddGuildMemberOpts , addGuildMemberOptsRoles :: Maybe [RoleId] , addGuildMemberOptsIsMuted :: Maybe Bool , addGuildMemberOptsIsDeafened :: Maybe Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON AddGuildMemberOpts where - toJSON AddGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- - [("access_token", toJSON <$> Just addGuildMemberOptsAccessToken ), - ("nick", toJSON <$> addGuildMemberOptsNickname ), - ("roles", toJSON <$> addGuildMemberOptsRoles ), - ("mute", toJSON <$> addGuildMemberOptsIsMuted ), - ("deaf", toJSON <$> addGuildMemberOptsIsDeafened )]] + toJSON AddGuildMemberOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("access_token", toJSON <$> Just addGuildMemberOptsAccessToken) + , ("nick" , toJSON <$> addGuildMemberOptsNickname) + , ("roles" , toJSON <$> addGuildMemberOptsRoles) + , ("mute" , toJSON <$> addGuildMemberOptsIsMuted) + , ("deaf" , toJSON <$> addGuildMemberOptsIsDeafened) + ] + ] data ModifyGuildMemberOpts = ModifyGuildMemberOpts { modifyGuildMemberOptsNickname :: Maybe T.Text @@ -211,19 +232,26 @@ data ModifyGuildMemberOpts = ModifyGuildMemberOpts , modifyGuildMemberOptsIsDeafened :: Maybe Bool , modifyGuildMemberOptsMoveToChannel :: Maybe ChannelId , modifyGuildMemberOptsTimeoutUntil :: Maybe (Maybe UTCTime) -- ^ If `Just Nothing`, the timeout will be removed. - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance Default ModifyGuildMemberOpts where - def = ModifyGuildMemberOpts Nothing Nothing Nothing Nothing Nothing Nothing + def = ModifyGuildMemberOpts Nothing Nothing Nothing Nothing Nothing Nothing instance ToJSON ModifyGuildMemberOpts where - toJSON ModifyGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- - [("nick", toJSON <$> modifyGuildMemberOptsNickname ), - ("roles", toJSON <$> modifyGuildMemberOptsRoles ), - ("mute", toJSON <$> modifyGuildMemberOptsIsMuted ), - ("deaf", toJSON <$> modifyGuildMemberOptsIsDeafened ), - ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel), - ("communication_disabled_until", toJSON <$> modifyGuildMemberOptsTimeoutUntil)]] + toJSON ModifyGuildMemberOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("nick" , toJSON <$> modifyGuildMemberOptsNickname) + , ("roles" , toJSON <$> modifyGuildMemberOptsRoles) + , ("mute" , toJSON <$> modifyGuildMemberOptsIsMuted) + , ("deaf" , toJSON <$> modifyGuildMemberOptsIsDeafened) + , ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel) + , ( "communication_disabled_until" + , toJSON <$> modifyGuildMemberOptsTimeoutUntil + ) + ] + ] data CreateGuildChannelOpts = CreateGuildChannelOptsText { @@ -238,29 +266,36 @@ data CreateGuildChannelOpts | CreateGuildChannelOptsCategory deriving (Show, Read, Eq, Ord) -createChannelOptsToJSON :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value -createChannelOptsToJSON name perms opts = object [(key, val) | (key, Just val) <- optsJSON] - where +createChannelOptsToJSON + :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value +createChannelOptsToJSON name perms opts = object + [ (key, val) | (key, Just val) <- optsJSON ] + where optsJSON = case opts of - CreateGuildChannelOptsText{..} -> - [("name", Just (String name)) - ,("type", Just (Number 0)) - ,("permission_overwrites", toJSON <$> Just perms) - ,("topic", toJSON <$> createGuildChannelOptsTopic) - ,("rate_limit_per_user", toJSON <$> createGuildChannelOptsUserMessageRateDelay) - ,("nsfw", toJSON <$> createGuildChannelOptsIsNSFW) - ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] - CreateGuildChannelOptsVoice{..} -> - [("name", Just (String name)) - ,("type", Just (Number 2)) - ,("permission_overwrites", toJSON <$> Just perms) - ,("bitrate", toJSON <$> createGuildChannelOptsBitrate) - ,("user_limit", toJSON <$> createGuildChannelOptsMaxUsers) - ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] + CreateGuildChannelOptsText {..} -> + [ ("name" , Just (String name)) + , ("type" , Just (Number 0)) + , ("permission_overwrites", toJSON <$> Just perms) + , ("topic" , toJSON <$> createGuildChannelOptsTopic) + , ( "rate_limit_per_user" + , toJSON <$> createGuildChannelOptsUserMessageRateDelay + ) + , ("nsfw" , toJSON <$> createGuildChannelOptsIsNSFW) + , ("parent_id", toJSON <$> createGuildChannelOptsCategoryId) + ] + CreateGuildChannelOptsVoice {..} -> + [ ("name" , Just (String name)) + , ("type" , Just (Number 2)) + , ("permission_overwrites", toJSON <$> Just perms) + , ("bitrate" , toJSON <$> createGuildChannelOptsBitrate) + , ("user_limit" , toJSON <$> createGuildChannelOptsMaxUsers) + , ("parent_id" , toJSON <$> createGuildChannelOptsCategoryId) + ] CreateGuildChannelOptsCategory -> - [("name", Just (String name)) - ,("type", Just (Number 4)) - ,("permission_overwrites", toJSON <$> Just perms)] + [ ("name" , Just (String name)) + , ("type" , Just (Number 4)) + , ("permission_overwrites", toJSON <$> Just perms) + ] -- | https://discord.com/developers/docs/resources/guild#modify-guild @@ -273,67 +308,73 @@ data ModifyGuildOpts = ModifyGuildOpts -- VerificationLevel -- DefaultMessageNotification -- ExplicitContentFilter - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON ModifyGuildOpts where - toJSON ModifyGuildOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> modifyGuildOptsName ), - ("afk_channel_id", toJSON <$> modifyGuildOptsAFKChannelId ), - ("icon", toJSON <$> modifyGuildOptsIcon ), - ("owner_id", toJSON <$> modifyGuildOptsOwnerId )] ] + toJSON ModifyGuildOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("name" , toJSON <$> modifyGuildOptsName) + , ("afk_channel_id", toJSON <$> modifyGuildOptsAFKChannelId) + , ("icon" , toJSON <$> modifyGuildOptsIcon) + , ("owner_id" , toJSON <$> modifyGuildOptsOwnerId) + ] + ] data GuildMembersTiming = GuildMembersTiming - { guildMembersTimingLimit :: Maybe Int - , guildMembersTimingAfter :: Maybe UserId - } deriving (Show, Read, Eq, Ord) + { guildMembersTimingLimit :: Maybe Int + , guildMembersTimingAfter :: Maybe UserId + } + deriving (Show, Read, Eq, Ord) guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) = let limit = case mLimit of - Nothing -> mempty - Just lim -> "limit" R.=: lim + Nothing -> mempty + Just lim -> "limit" R.=: lim after = case mAfter of - Nothing -> mempty - Just aft -> "after" R.=: show aft - in limit <> after + Nothing -> mempty + Just aft -> "after" R.=: show aft + in limit <> after guildMajorRoute :: GuildRequest a -> String guildMajorRoute c = case c of - (GetGuild g) -> "guild " <> show g - (ModifyGuild g _) -> "guild " <> show g - (DeleteGuild g) -> "guild " <> show g - (GetGuildChannels g) -> "guild_chan " <> show g - (CreateGuildChannel g _ _ _) -> "guild_chan " <> show g + (GetGuild g ) -> "guild " <> show g + (ModifyGuild g _ ) -> "guild " <> show g + (DeleteGuild g ) -> "guild " <> show g + (GetGuildChannels g ) -> "guild_chan " <> show g + (CreateGuildChannel g _ _ _ ) -> "guild_chan " <> show g (ModifyGuildChannelPositions g _) -> "guild_chan " <> show g - (GetGuildMember g _) -> "guild_memb " <> show g - (ListGuildMembers g _) -> "guild_membs " <> show g - (AddGuildMember g _ _) -> "guild_membs " <> show g - (ModifyGuildMember g _ _) -> "guild_membs " <> show g - (ModifyCurrentUserNick g _) -> "guild_membs " <> show g - (AddGuildMemberRole g _ _) -> "guild_membs " <> show g - (RemoveGuildMemberRole g _ _) -> "guild_membs " <> show g - (RemoveGuildMember g _) -> "guild_membs " <> show g - (GetGuildBan g _) -> "guild_bans " <> show g - (GetGuildBans g) -> "guild_bans " <> show g - (CreateGuildBan g _ _) -> "guild_ban " <> show g - (RemoveGuildBan g _) -> "guild_ban " <> show g - (GetGuildRoles g) -> "guild_roles " <> show g - (CreateGuildRole g _) -> "guild_roles " <> show g - (ModifyGuildRolePositions g _) -> "guild_roles " <> show g - (ModifyGuildRole g _ _) -> "guild_role " <> show g - (DeleteGuildRole g _ ) -> "guild_role " <> show g - (GetGuildPruneCount g _) -> "guild_prune " <> show g - (BeginGuildPrune g _) -> "guild_prune " <> show g - (GetGuildVoiceRegions g) -> "guild_voice " <> show g - (GetGuildInvites g) -> "guild_invit " <> show g - (GetGuildIntegrations g) -> "guild_integ " <> show g - (CreateGuildIntegration g _ _) -> "guild_integ " <> show g - (ModifyGuildIntegration g _ _) -> "guild_intgr " <> show g - (DeleteGuildIntegration g _) -> "guild_intgr " <> show g - (SyncGuildIntegration g _) -> "guild_sync " <> show g - (GetGuildWidget g) -> "guild_widget " <> show g - (ModifyGuildWidget g _) -> "guild_widget " <> show g - (GetGuildVanityURL g) -> "guild " <> show g + (GetGuildMember g _) -> "guild_memb " <> show g + (ListGuildMembers g _) -> "guild_membs " <> show g + (AddGuildMember g _ _ ) -> "guild_membs " <> show g + (ModifyGuildMember g _ _ ) -> "guild_membs " <> show g + (ModifyCurrentUserNick g _ ) -> "guild_membs " <> show g + (AddGuildMemberRole g _ _ ) -> "guild_membs " <> show g + (RemoveGuildMemberRole g _ _ ) -> "guild_membs " <> show g + (RemoveGuildMember g _ ) -> "guild_membs " <> show g + (GetGuildBan g _ ) -> "guild_bans " <> show g + (GetGuildBans g ) -> "guild_bans " <> show g + (CreateGuildBan g _ _ ) -> "guild_ban " <> show g + (RemoveGuildBan g _ ) -> "guild_ban " <> show g + (GetGuildRoles g ) -> "guild_roles " <> show g + (CreateGuildRole g _ ) -> "guild_roles " <> show g + (ModifyGuildRolePositions g _ ) -> "guild_roles " <> show g + (ModifyGuildRole g _ _ ) -> "guild_role " <> show g + (DeleteGuildRole g _ ) -> "guild_role " <> show g + (GetGuildPruneCount g _ ) -> "guild_prune " <> show g + (BeginGuildPrune g _ ) -> "guild_prune " <> show g + (GetGuildVoiceRegions g ) -> "guild_voice " <> show g + (GetGuildInvites g ) -> "guild_invit " <> show g + (GetGuildIntegrations g ) -> "guild_integ " <> show g + (CreateGuildIntegration g _ _ ) -> "guild_integ " <> show g + (ModifyGuildIntegration g _ _ ) -> "guild_intgr " <> show g + (DeleteGuildIntegration g _ ) -> "guild_intgr " <> show g + (SyncGuildIntegration g _ ) -> "guild_sync " <> show g + (GetGuildWidget g ) -> "guild_widget " <> show g + (ModifyGuildWidget g _ ) -> "guild_widget " <> show g + (GetGuildVanityURL g ) -> "guild " <> show g guilds :: R.Url 'R.Https @@ -341,114 +382,122 @@ guilds = baseUrl /: "guilds" guildJsonRequest :: GuildRequest r -> JsonRequest guildJsonRequest c = case c of - (GetGuild guild) -> - Get (guilds // guild) mempty + (GetGuild guild) -> Get (guilds // guild) mempty (ModifyGuild guild patch) -> - Patch (guilds // guild) (pure (R.ReqBodyJson patch)) mempty + Patch (guilds // guild) (pure (R.ReqBodyJson patch)) mempty - (DeleteGuild guild) -> - Delete (guilds // guild) mempty + (DeleteGuild guild) -> Delete (guilds // guild) mempty - (GetGuildChannels guild) -> - Get (guilds // guild /: "channels") mempty + (GetGuildChannels guild) -> Get (guilds // guild /: "channels") mempty - (CreateGuildChannel guild name perms patch) -> - Post (guilds // guild /: "channels") - (pure (R.ReqBodyJson (createChannelOptsToJSON name perms patch))) mempty + (CreateGuildChannel guild name perms patch) -> Post + (guilds // guild /: "channels") + (pure (R.ReqBodyJson (createChannelOptsToJSON name perms patch))) + mempty (ModifyGuildChannelPositions guild newlocs) -> - let patch = map (\(a, b) -> object [("id", toJSON a) - ,("position", toJSON b)]) newlocs - in Patch (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + let patch = map + (\(a, b) -> object [("id", toJSON a), ("position", toJSON b)]) + newlocs + in Patch (guilds // guild /: "channels") + (pure (R.ReqBodyJson patch)) + mempty (GetGuildMember guild member) -> - Get (guilds // guild /: "members" // member) mempty + Get (guilds // guild /: "members" // member) mempty (ListGuildMembers guild range) -> - Get (guilds // guild /: "members") (guildMembersTimingToQuery range) + Get (guilds // guild /: "members") (guildMembersTimingToQuery range) (AddGuildMember guild user patch) -> - Put (guilds // guild /: "members" // user) (R.ReqBodyJson patch) mempty + Put (guilds // guild /: "members" // user) (R.ReqBodyJson patch) mempty - (ModifyGuildMember guild member patch) -> - Patch (guilds // guild /: "members" // member) (pure (R.ReqBodyJson patch)) mempty + (ModifyGuildMember guild member patch) -> Patch + (guilds // guild /: "members" // member) + (pure (R.ReqBodyJson patch)) + mempty (ModifyCurrentUserNick guild name) -> - let patch = object ["nick" .= name] - in Patch (guilds // guild /: "members/@me/nick") (pure (R.ReqBodyJson patch)) mempty + let patch = object ["nick" .= name] + in Patch (guilds // guild /: "members/@me/nick") + (pure (R.ReqBodyJson patch)) + mempty (AddGuildMemberRole guild user role) -> - let body = R.ReqBodyJson (object []) - in Put (guilds // guild /: "members" // user /: "roles" // role) body mempty + let body = R.ReqBodyJson (object []) + in Put (guilds // guild /: "members" // user /: "roles" // role) + body + mempty (RemoveGuildMemberRole guild user role) -> - Delete (guilds // guild /: "members" // user /: "roles" // role) mempty + Delete (guilds // guild /: "members" // user /: "roles" // role) mempty (RemoveGuildMember guild user) -> - Delete (guilds // guild /: "members" // user) mempty + Delete (guilds // guild /: "members" // user) mempty (GetGuildBan guild user) -> Get (guilds // guild /: "bans" // user) mempty - (GetGuildBans guild) -> Get (guilds // guild /: "bans") mempty + (GetGuildBans guild ) -> Get (guilds // guild /: "bans") mempty (CreateGuildBan guild user patch) -> - Put (guilds // guild /: "bans" // user) (R.ReqBodyJson patch) mempty + Put (guilds // guild /: "bans" // user) (R.ReqBodyJson patch) mempty (RemoveGuildBan guild ban) -> - Delete (guilds // guild /: "bans" // ban) mempty + Delete (guilds // guild /: "bans" // ban) mempty - (GetGuildRoles guild) -> - Get (guilds // guild /: "roles") mempty + (GetGuildRoles guild) -> Get (guilds // guild /: "roles") mempty (CreateGuildRole guild patch) -> - Post (guilds // guild /: "roles") (pure (R.ReqBodyJson patch)) mempty + Post (guilds // guild /: "roles") (pure (R.ReqBodyJson patch)) mempty (ModifyGuildRolePositions guild patch) -> - let body = map (\(role, pos) -> object ["id".=role, "position".=pos]) patch - in Patch (guilds // guild /: "roles") (pure (R.ReqBodyJson body)) mempty + let body = + map (\(role, pos) -> object ["id" .= role, "position" .= pos]) patch + in Patch (guilds // guild /: "roles") (pure (R.ReqBodyJson body)) mempty - (ModifyGuildRole guild role patch) -> - Patch (guilds // guild /: "roles" // role) (pure (R.ReqBodyJson patch)) mempty + (ModifyGuildRole guild role patch) -> Patch + (guilds // guild /: "roles" // role) + (pure (R.ReqBodyJson patch)) + mempty (DeleteGuildRole guild role) -> - Delete (guilds // guild /: "roles" // role) mempty + Delete (guilds // guild /: "roles" // role) mempty (GetGuildPruneCount guild days) -> - Get (guilds // guild /: "prune") ("days" R.=: days) + Get (guilds // guild /: "prune") ("days" R.=: days) (BeginGuildPrune guild days) -> - Post (guilds // guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) + Post (guilds // guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) - (GetGuildVoiceRegions guild) -> - Get (guilds // guild /: "regions") mempty + (GetGuildVoiceRegions guild) -> Get (guilds // guild /: "regions") mempty - (GetGuildInvites guild) -> - Get (guilds // guild /: "invites") mempty + (GetGuildInvites guild) -> Get (guilds // guild /: "invites") mempty (GetGuildIntegrations guild) -> - Get (guilds // guild /: "integrations") mempty + Get (guilds // guild /: "integrations") mempty (CreateGuildIntegration guild iid opts) -> - let patch = object [("type" .= createGuildIntegrationOptsType opts) ,("id" .= iid)] - in Post (guilds // guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty + let patch = + object ["type" .= createGuildIntegrationOptsType opts, "id" .= iid] + in Post (guilds // guild /: "integrations") + (pure (R.ReqBodyJson patch)) + mempty (ModifyGuildIntegration guild iid patch) -> - let body = pure (R.ReqBodyJson patch) - in Patch (guilds // guild /: "integrations" // iid) body mempty + let body = pure (R.ReqBodyJson patch) + in Patch (guilds // guild /: "integrations" // iid) body mempty (DeleteGuildIntegration guild integ) -> - Delete (guilds // guild /: "integrations" // integ) mempty + Delete (guilds // guild /: "integrations" // integ) mempty (SyncGuildIntegration guild integ) -> - Post (guilds // guild /: "integrations" // integ) (pure R.NoReqBody) mempty + Post (guilds // guild /: "integrations" // integ) (pure R.NoReqBody) mempty - (GetGuildWidget guild) -> - Get (guilds // guild /: "integrations") mempty + (GetGuildWidget guild) -> Get (guilds // guild /: "integrations") mempty (ModifyGuildWidget guild patch) -> - Patch (guilds // guild /: "widget") (pure (R.ReqBodyJson patch)) mempty + Patch (guilds // guild /: "widget") (pure (R.ReqBodyJson patch)) mempty - (GetGuildVanityURL guild) -> - Get (guilds // guild /: "vanity-url") mempty + (GetGuildVanityURL guild) -> Get (guilds // guild /: "vanity-url") mempty diff --git a/src/Discord/Internal/Rest/HTTP.hs b/src/Discord/Internal/Rest/HTTP.hs index 475a1cf6..ba416329 100644 --- a/src/Discord/Internal/Rest/HTTP.hs +++ b/src/Discord/Internal/Rest/HTTP.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-} -- | Provide HTTP primitives @@ -10,79 +9,94 @@ module Discord.Internal.Rest.HTTP , RestCallInternalException(..) ) where -import Prelude hiding (log) - -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent (threadDelay) -import Control.Exception.Safe (try) -import Control.Concurrent.MVar -import Control.Concurrent.Chan -import Data.Ix (inRange) -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Text.Read (readMaybe) -import Data.Maybe (fromMaybe) -import qualified Network.HTTP.Req as R -import qualified Data.Map.Strict as M - -import Discord.Internal.Types -import Discord.Internal.Rest.Prelude +import Prelude hiding ( log ) + +import Control.Concurrent ( threadDelay ) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Exception.Safe ( try ) +import Control.Monad.IO.Class ( liftIO ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Ix ( inRange ) +import qualified Data.Map.Strict as M +import Data.Maybe ( fromMaybe ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock.POSIX ( POSIXTime + , getPOSIXTime + ) +import qualified Network.HTTP.Req as R +import Text.Read ( readMaybe ) + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types data RestCallInternalException = RestCallInternalErrorCode Int B.ByteString B.ByteString | RestCallInternalNoParse String BL.ByteString | RestCallInternalHttpException R.HttpException deriving (Show) -restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) - -> Chan T.Text -> IO () +restLoop + :: Auth + -> Chan + ( String + , JsonRequest + , MVar (Either RestCallInternalException BL.ByteString) + ) + -> Chan T.Text + -> IO () restLoop auth urls log = loop M.empty - where + where loop ratelocker = do threadDelay (40 * 1000) (route, request, thread) <- readChan urls - curtime <- getPOSIXTime + curtime <- getPOSIXTime case compareRate ratelocker route curtime of - Locked -> do writeChan urls (route, request, thread) - loop ratelocker - Available -> do let action = compileRequest auth request - reqIO <- try $ restIOtoIO (tryRequest log action) - case reqIO :: Either R.HttpException (RequestResponse, Timeout) of - Left e -> do - writeChan log ("rest - http exception " <> T.pack (show e)) - putMVar thread (Left (RestCallInternalHttpException e)) - loop ratelocker - Right (resp, retry) -> do - case resp of - -- decode "[]" == () for expected empty calls - ResponseByteString "" -> putMVar thread (Right "[]") - ResponseByteString bs -> putMVar thread (Right bs) - ResponseErrorCode e s b -> - putMVar thread (Left (RestCallInternalErrorCode e s b)) - ResponseTryAgain -> writeChan urls (route, request, thread) - case retry of - GlobalWait i -> do - writeChan log ("rest - GLOBAL WAIT LIMIT: " - <> T.pack (show ((i - curtime) * 1000))) - threadDelay $ round ((i - curtime + 0.1) * 1000) - loop ratelocker - PathWait i -> loop $ M.insert route i (removeAllExpire ratelocker curtime) - NoLimit -> loop ratelocker + Locked -> do + writeChan urls (route, request, thread) + loop ratelocker + Available -> do + let action = compileRequest auth request + reqIO <- try $ restIOtoIO (tryRequest log action) + case reqIO :: Either R.HttpException (RequestResponse, Timeout) of + Left e -> do + writeChan log ("rest - http exception " <> T.pack (show e)) + putMVar thread (Left (RestCallInternalHttpException e)) + loop ratelocker + Right (resp, retry) -> do + case resp of + -- decode "[]" == () for expected empty calls + ResponseByteString "" -> putMVar thread (Right "[]") + ResponseByteString bs -> putMVar thread (Right bs) + ResponseErrorCode e s b -> + putMVar thread (Left (RestCallInternalErrorCode e s b)) + ResponseTryAgain -> writeChan urls (route, request, thread) + case retry of + GlobalWait i -> do + writeChan + log + ( "rest - GLOBAL WAIT LIMIT: " + <> T.pack (show ((i - curtime) * 1000)) + ) + threadDelay $ round ((i - curtime + 0.1) * 1000) + loop ratelocker + PathWait i -> + loop $ M.insert route i (removeAllExpire ratelocker curtime) + NoLimit -> loop ratelocker data RateLimited = Available | Locked compareRate :: M.Map String POSIXTime -> String -> POSIXTime -> RateLimited -compareRate ratelocker route curtime = - case M.lookup route ratelocker of - Just unlockTime -> if curtime < unlockTime then Locked else Available - Nothing -> Available +compareRate ratelocker route curtime = case M.lookup route ratelocker of + Just unlockTime -> if curtime < unlockTime then Locked else Available + Nothing -> Available -removeAllExpire :: M.Map String POSIXTime -> POSIXTime -> M.Map String POSIXTime -removeAllExpire ratelocker curtime = - if M.size ratelocker > 100 then M.filter (> curtime) ratelocker - else ratelocker +removeAllExpire + :: M.Map String POSIXTime -> POSIXTime -> M.Map String POSIXTime +removeAllExpire ratelocker curtime = if M.size ratelocker > 100 + then M.filter (> curtime) ratelocker + else ratelocker data RequestResponse = ResponseTryAgain | ResponseByteString BL.ByteString @@ -93,42 +107,58 @@ data Timeout = GlobalWait POSIXTime | PathWait POSIXTime | NoLimit -tryRequest :: Chan T.Text -> RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout) +tryRequest + :: Chan T.Text -> RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout) tryRequest _log action = do resp <- action - now <- liftIO getPOSIXTime - let body = R.responseBody resp - code = R.responseStatusCode resp - status = R.responseStatusMessage resp - global = (Just ("true" :: String) ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global" - remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining" :: Integer - reset = withDelta . fromMaybe 10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset-After" - - withDelta :: Double -> POSIXTime - withDelta dt = now + fromRational (toRational dt) - - if | code == 429 -> pure (ResponseTryAgain, if global then GlobalWait reset - else PathWait reset) - | code `elem` [500,502] -> pure (ResponseTryAgain, NoLimit) - | inRange (200,299) code -> pure ( ResponseByteString body - , if remain > 0 then NoLimit else PathWait reset ) - | inRange (400,499) code -> pure (ResponseErrorCode code status (BL.toStrict body) - , if remain > 0 then NoLimit else PathWait reset ) - | otherwise -> pure (ResponseErrorCode code status (BL.toStrict body), NoLimit) + now <- liftIO getPOSIXTime + let + body = R.responseBody resp + code = R.responseStatusCode resp + status = R.responseStatusMessage resp + global = (Just ("true" :: String) ==) $ readMaybeBS =<< R.responseHeader + resp + "X-RateLimit-Global" + remain = + fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp + "X-RateLimit-Remaining" :: Integer + reset = withDelta . fromMaybe 10 $ readMaybeBS =<< R.responseHeader + resp + "X-RateLimit-Reset-After" + + withDelta :: Double -> POSIXTime + withDelta dt = now + fromRational (toRational dt) + + if + | code == 429 -> pure + (ResponseTryAgain, if global then GlobalWait reset else PathWait reset) + | code `elem` [500, 502] -> pure (ResponseTryAgain, NoLimit) + | inRange (200, 299) code -> pure + (ResponseByteString body, if remain > 0 then NoLimit else PathWait reset) + | inRange (400, 499) code -> pure + ( ResponseErrorCode code status (BL.toStrict body) + , if remain > 0 then NoLimit else PathWait reset + ) + | otherwise -> pure + (ResponseErrorCode code status (BL.toStrict body), NoLimit) readMaybeBS :: Read a => B.ByteString -> Maybe a readMaybeBS = readMaybe . T.unpack . TE.decodeUtf8 compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse compileRequest auth request = action - where + where authopt = authHeader auth <> R.header "X-RateLimit-Precision" "millisecond" - action = case request of - (Delete url opts) -> R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts) - (Get url opts) -> R.req R.GET url R.NoReqBody R.lbsResponse (authopt <> opts) - (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) - (Patch url body opts) -> do b <- body - R.req R.PATCH url b R.lbsResponse (authopt <> opts) - (Post url body opts) -> do b <- body - R.req R.POST url b R.lbsResponse (authopt <> opts) + action = case request of + (Delete url opts) -> + R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts) + (Get url opts) -> + R.req R.GET url R.NoReqBody R.lbsResponse (authopt <> opts) + (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) + (Patch url body opts) -> do + b <- body + R.req R.PATCH url b R.lbsResponse (authopt <> opts) + (Post url body opts) -> do + b <- body + R.req R.POST url b R.lbsResponse (authopt <> opts) diff --git a/src/Discord/Internal/Rest/Interactions.hs b/src/Discord/Internal/Rest/Interactions.hs index d793daa6..ee7cfe83 100644 --- a/src/Discord/Internal/Rest/Interactions.hs +++ b/src/Discord/Internal/Rest/Interactions.hs @@ -5,36 +5,39 @@ module Discord.Internal.Rest.Interactions where -import Data.Aeson (encode) -import qualified Data.ByteString.Lazy as BL -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types -import Discord.Internal.Types.Interactions -import Network.HTTP.Client.MultipartFormData (PartM, partBS) -import Network.HTTP.Req as R +import Data.Aeson ( encode ) +import qualified Data.ByteString.Lazy as BL +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Discord.Internal.Types.Interactions +import Network.HTTP.Client.MultipartFormData + ( PartM + , partBS + ) +import Network.HTTP.Req as R data InteractionResponseRequest a where - CreateInteractionResponse :: InteractionId -> InteractionToken -> InteractionResponse -> InteractionResponseRequest () - GetOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest Message - EditOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message - DeleteOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest () - CreateFollowupInteractionMessage :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message - GetFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest Message - EditFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponse -> InteractionResponseRequest Message - DeleteFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest () + CreateInteractionResponse ::InteractionId -> InteractionToken -> InteractionResponse -> InteractionResponseRequest () + GetOriginalInteractionResponse ::ApplicationId -> InteractionToken -> InteractionResponseRequest Message + EditOriginalInteractionResponse ::ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message + DeleteOriginalInteractionResponse ::ApplicationId -> InteractionToken -> InteractionResponseRequest () + CreateFollowupInteractionMessage ::ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message + GetFollowupInteractionMessage ::ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest Message + EditFollowupInteractionMessage ::ApplicationId -> InteractionToken -> MessageId -> InteractionResponse -> InteractionResponseRequest Message + DeleteFollowupInteractionMessage ::ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest () instance Request (InteractionResponseRequest a) where jsonRequest = interactionResponseJsonRequest - majorRoute = interactionResponseMajorRoute + majorRoute = interactionResponseMajorRoute interactionResponseMajorRoute :: InteractionResponseRequest a -> String interactionResponseMajorRoute a = case a of - (CreateInteractionResponse iid _ _) -> "intresp " <> show iid - (GetOriginalInteractionResponse aid _) -> "intresp " <> show aid - (EditOriginalInteractionResponse aid _ _) -> "intresp " <> show aid - (DeleteOriginalInteractionResponse aid _) -> "intresp " <> show aid + (CreateInteractionResponse iid _ _ ) -> "intresp " <> show iid + (GetOriginalInteractionResponse aid _ ) -> "intresp " <> show aid + (EditOriginalInteractionResponse aid _ _ ) -> "intresp " <> show aid + (DeleteOriginalInteractionResponse aid _ ) -> "intresp " <> show aid (CreateFollowupInteractionMessage iid _ _) -> "intrespf " <> show iid - (GetFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + (GetFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid (EditFollowupInteractionMessage aid _ _ _) -> "intrespf " <> show aid (DeleteFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid @@ -43,8 +46,10 @@ interaction aid it = baseUrl /: "webhooks" // aid /: it /: "messages" interactionResponseJsonRequest :: InteractionResponseRequest a -> JsonRequest interactionResponseJsonRequest a = case a of - (CreateInteractionResponse iid it i) -> - Post (baseUrl /: "interactions" // iid /: it /: "callback") (convert i) mempty + (CreateInteractionResponse iid it i) -> Post + (baseUrl /: "interactions" // iid /: it /: "callback") + (convert i) + mempty (GetOriginalInteractionResponse aid it) -> Get (interaction aid it /: "@original") mempty (EditOriginalInteractionResponse aid it i) -> @@ -59,14 +64,19 @@ interactionResponseJsonRequest a = case a of Patch (interaction aid it // mid) (convert i) mempty (DeleteFollowupInteractionMessage aid it mid) -> Delete (interaction aid it // mid) mempty - where - convert :: InteractionResponse -> RestIO ReqBodyMultipart - convert ir@(InteractionResponseChannelMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) - convert ir@(InteractionResponseUpdateMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) - convert ir = R.reqBodyMultipart [partBS "payload_json" $ BL.toStrict $ encode ir] - convertIRM :: InteractionResponseMessage -> RestIO ReqBodyMultipart - convertIRM irm = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode irm) : convert' irm) - convert' :: InteractionResponseMessage -> [PartM IO] - convert' InteractionResponseMessage {..} = case interactionResponseMessageEmbeds of + where + convert :: InteractionResponse -> RestIO ReqBodyMultipart + convert ir@(InteractionResponseChannelMessage irm) = R.reqBodyMultipart + (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir@(InteractionResponseUpdateMessage irm) = R.reqBodyMultipart + (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir = + R.reqBodyMultipart [partBS "payload_json" $ BL.toStrict $ encode ir] + convertIRM :: InteractionResponseMessage -> RestIO ReqBodyMultipart + convertIRM irm = R.reqBodyMultipart + (partBS "payload_json" (BL.toStrict $ encode irm) : convert' irm) + convert' :: InteractionResponseMessage -> [PartM IO] + convert' InteractionResponseMessage {..} = + case interactionResponseMessageEmbeds of Nothing -> [] - Just f -> (maybeEmbed . Just) =<< f + Just f -> (maybeEmbed . Just) =<< f diff --git a/src/Discord/Internal/Rest/Invite.hs b/src/Discord/Internal/Rest/Invite.hs index 79b4aa53..477a126b 100644 --- a/src/Discord/Internal/Rest/Invite.hs +++ b/src/Discord/Internal/Rest/Invite.hs @@ -1,8 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | Provides actions for Channel API interactions @@ -10,34 +7,34 @@ module Discord.Internal.Rest.Invite ( InviteRequest(..) ) where -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T +import qualified Data.Text as T +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types instance Request (InviteRequest a) where - majorRoute = inviteMajorRoute + majorRoute = inviteMajorRoute jsonRequest = inviteJsonRequest -- | Data constructor for requests. See data InviteRequest a where -- | Get invite for given code - GetInvite :: T.Text -> InviteRequest Invite + GetInvite ::T.Text -> InviteRequest Invite -- | Delete invite by code - DeleteInvite :: T.Text -> InviteRequest Invite + DeleteInvite ::T.Text -> InviteRequest Invite inviteMajorRoute :: InviteRequest a -> String inviteMajorRoute c = case c of - (GetInvite _) -> "invite " - (DeleteInvite _) -> "invite " + (GetInvite _) -> "invite " + (DeleteInvite _) -> "invite " invite :: R.Url 'R.Https invite = baseUrl /: "invites" inviteJsonRequest :: InviteRequest r -> JsonRequest inviteJsonRequest c = case c of - (GetInvite g) -> Get (invite R./: g) mempty + (GetInvite g) -> Get (invite R./: g) mempty (DeleteInvite g) -> Delete (invite R./: g) mempty diff --git a/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs index c7040764..3e3d7b92 100644 --- a/src/Discord/Internal/Rest/Prelude.hs +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -6,16 +6,18 @@ -- | Utility and base types and functions for the Discord Rest API module Discord.Internal.Rest.Prelude where -import Prelude hiding (log) -import Control.Exception.Safe (throwIO) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE +import Control.Exception.Safe ( throwIO ) +import Control.Monad.IO.Class ( MonadIO + , liftIO + ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Prelude hiding ( log ) -import qualified Network.HTTP.Req as R +import qualified Network.HTTP.Req as R -import Discord.Internal.Types +import Discord.Internal.Types -- | The api version to use. apiVersion :: T.Text @@ -29,9 +31,9 @@ baseUrl = R.https "discord.com" R./: "api" R./: apiVersion' -- | Discord requires HTTP headers for authentication. authHeader :: Auth -> R.Option 'R.Https authHeader auth = - R.header "Authorization" (TE.encodeUtf8 (authToken auth)) - <> R.header "User-Agent" agent - where + R.header "Authorization" (TE.encodeUtf8 (authToken auth)) + <> R.header "User-Agent" agent + where -- | https://discord.com/developers/docs/reference#user-agent -- Second place where the library version is noted agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.12.5)" @@ -44,11 +46,11 @@ infixl 5 // -- | A compiled HTTP request ready to execute data JsonRequest where - Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest - Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest - Put :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest - Patch :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest - Post :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + Delete ::R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Get ::R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Put ::R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest + Patch ::R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + Post ::R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest class Request a where -- | used for putting a request into a rate limit bucket @@ -66,4 +68,5 @@ instance R.MonadHttp RestIO where -- | Throw actual exceptions handleHttpException = liftIO . throwIO -- | Don't throw exceptions on http error codes like 404 - getHttpConfig = pure $ R.defaultHttpConfig { R.httpConfigCheckResponse = \_ _ _ -> Nothing } + getHttpConfig = + pure $ R.defaultHttpConfig { R.httpConfigCheckResponse = \_ _ _ -> Nothing } diff --git a/src/Discord/Internal/Rest/ScheduledEvents.hs b/src/Discord/Internal/Rest/ScheduledEvents.hs index 12334832..37d74924 100644 --- a/src/Discord/Internal/Rest/ScheduledEvents.hs +++ b/src/Discord/Internal/Rest/ScheduledEvents.hs @@ -4,15 +4,15 @@ -- | Provides actions for Scheduled Event API module Discord.Internal.Rest.ScheduledEvents - ( ScheduledEventRequest(..) - ) where + ( ScheduledEventRequest(..) + ) where import Data.Aeson ( ToJSON(toJSON) ) import Discord.Internal.Rest.Prelude ( (//) , JsonRequest(..) , Request - ( jsonRequest - , majorRoute - ) + ( jsonRequest + , majorRoute + ) , baseUrl ) import Discord.Internal.Types.Prelude ( GuildId @@ -59,16 +59,14 @@ sevEndpoint :: GuildId -> R.Url 'R.Https sevEndpoint gid = baseUrl /: "guilds" // gid /: "scheduled-events" instance Request (ScheduledEventRequest a) where - majorRoute = const "scheduledEvent" - jsonRequest rq = case rq of - ListScheduledEvents gid -> Get (sevEndpoint gid) mempty - GetScheduledEvent gid ev -> Get (sevEndpoint gid // ev) mempty - CreateScheduledEvent gid ev -> - Post (sevEndpoint gid) (pure $ R.ReqBodyJson $ toJSON ev) mempty - ModifyScheduledEvent gid evi ev -> Patch - (sevEndpoint gid // evi) - (pure $ R.ReqBodyJson $ toJSON ev) - mempty - DeleteScheduledEvent gid evi -> Delete (sevEndpoint gid // evi) mempty - GetScheduledEventUsers gid evi -> - Get (sevEndpoint gid // evi /: "users") mempty + majorRoute = const "scheduledEvent" + jsonRequest rq = case rq of + ListScheduledEvents gid -> Get (sevEndpoint gid) mempty + GetScheduledEvent gid ev -> Get (sevEndpoint gid // ev) mempty + CreateScheduledEvent gid ev -> + Post (sevEndpoint gid) (pure $ R.ReqBodyJson $ toJSON ev) mempty + ModifyScheduledEvent gid evi ev -> + Patch (sevEndpoint gid // evi) (pure $ R.ReqBodyJson $ toJSON ev) mempty + DeleteScheduledEvent gid evi -> Delete (sevEndpoint gid // evi) mempty + GetScheduledEventUsers gid evi -> + Get (sevEndpoint gid // evi /: "users") mempty diff --git a/src/Discord/Internal/Rest/User.hs b/src/Discord/Internal/Rest/User.hs index d15229d6..9185375e 100644 --- a/src/Discord/Internal/Rest/User.hs +++ b/src/Discord/Internal/Rest/User.hs @@ -1,7 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | Provides actions for Channel API interactions @@ -12,21 +10,21 @@ module Discord.Internal.Rest.User ) where -import Data.Aeson -import Codec.Picture -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Base64 as B64 +import Codec.Picture +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types instance Request (UserRequest a) where - majorRoute = userMajorRoute + majorRoute = userMajorRoute jsonRequest = userJsonRequest @@ -35,68 +33,68 @@ data UserRequest a where -- | Returns the 'User' object of the requester's account. For OAuth2, this requires -- the identify scope, which will return the object without an email, and optionally -- the email scope, which returns the object with an email. - GetCurrentUser :: UserRequest User + GetCurrentUser ::UserRequest User -- | Returns a 'User' for a given user ID - GetUser :: UserId -> UserRequest User + GetUser ::UserId -> UserRequest User -- | Modify user's username & avatar pic - ModifyCurrentUser :: T.Text -> CurrentUserAvatar -> UserRequest User + ModifyCurrentUser ::T.Text -> CurrentUserAvatar -> UserRequest User -- | Returns a list of user 'Guild' objects the current user is a member of. -- Requires the guilds OAuth2 scope. - GetCurrentUserGuilds :: UserRequest [PartialGuild] + GetCurrentUserGuilds ::UserRequest [PartialGuild] -- | Leave a guild. - LeaveGuild :: GuildId -> UserRequest () + LeaveGuild ::GuildId -> UserRequest () -- | Returns a list of DM 'Channel' objects - GetUserDMs :: UserRequest [Channel] + GetUserDMs ::UserRequest [Channel] -- | Create a new DM channel with a user. Returns a DM 'Channel' object. - CreateDM :: UserId -> UserRequest Channel + CreateDM ::UserId -> UserRequest Channel - GetUserConnections :: UserRequest [ConnectionObject] + GetUserConnections ::UserRequest [ConnectionObject] -- | Formatted avatar data https://discord.com/developers/docs/resources/user#avatar-data -data CurrentUserAvatar = CurrentUserAvatar T.Text +newtype CurrentUserAvatar = CurrentUserAvatar T.Text deriving (Show, Read, Eq, Ord) parseCurrentUserAvatar :: B.ByteString -> Either T.Text CurrentUserAvatar -parseCurrentUserAvatar bs = - case decodeImage bs of - Left e -> Left (T.pack e) - Right im -> Right $ CurrentUserAvatar $ "data:image/png;base64," - <> TE.decodeUtf8 (B64.encode (BL.toStrict (encodePng (convertRGBA8 im)))) +parseCurrentUserAvatar bs = case decodeImage bs of + Left e -> Left (T.pack e) + Right im -> + Right $ CurrentUserAvatar $ "data:image/png;base64," <> TE.decodeUtf8 + (B64.encode (BL.toStrict (encodePng (convertRGBA8 im)))) userMajorRoute :: UserRequest a -> String userMajorRoute c = case c of - (GetCurrentUser) -> "me " - (GetUser _) -> "user " - (ModifyCurrentUser _ _) -> "modify_user " - (GetCurrentUserGuilds) -> "get_user_guilds " - (LeaveGuild g) -> "leave_guild " <> show g - (GetUserDMs) -> "get_dms " - (CreateDM _) -> "make_dm " - (GetUserConnections) -> "connections " + GetCurrentUser -> "me " + (GetUser _ ) -> "user " + (ModifyCurrentUser _ _) -> "modify_user " + GetCurrentUserGuilds -> "get_user_guilds " + (LeaveGuild g) -> "leave_guild " <> show g + GetUserDMs -> "get_dms " + (CreateDM _) -> "make_dm " + GetUserConnections -> "connections " users :: R.Url 'R.Https users = baseUrl /: "users" userJsonRequest :: UserRequest r -> JsonRequest userJsonRequest c = case c of - (GetCurrentUser) -> Get (users /: "@me") mempty + GetCurrentUser -> Get (users /: "@me") mempty - (GetUser user) -> Get (users // user ) mempty + (GetUser user) -> Get (users // user) mempty - (ModifyCurrentUser name (CurrentUserAvatar im)) -> - Patch (users /: "@me") (pure (R.ReqBodyJson (object [ "username" .= name - , "avatar" .= im ]))) mempty + (ModifyCurrentUser name (CurrentUserAvatar im)) -> Patch + (users /: "@me") + (pure (R.ReqBodyJson (object ["username" .= name, "avatar" .= im]))) + mempty - (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty + GetCurrentUserGuilds -> Get (users /: "@me" /: "guilds") mempty - (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" // guild) mempty + (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" // guild) mempty - (GetUserDMs) -> Get (users /: "@me" /: "channels") mempty + GetUserDMs -> Get (users /: "@me" /: "channels") mempty (CreateDM user) -> - let body = R.ReqBodyJson $ object ["recipient_id" .= user] - in Post (users /: "@me" /: "channels") (pure body) mempty + let body = R.ReqBodyJson $ object ["recipient_id" .= user] + in Post (users /: "@me" /: "channels") (pure body) mempty - (GetUserConnections) -> - Get (users /: "@me" /: "connections") mempty + GetUserConnections -> Get (users /: "@me" /: "connections") mempty diff --git a/src/Discord/Internal/Rest/Voice.hs b/src/Discord/Internal/Rest/Voice.hs index b2012ae5..58beb6d1 100644 --- a/src/Discord/Internal/Rest/Voice.hs +++ b/src/Discord/Internal/Rest/Voice.hs @@ -1,7 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | Provides actions for Voice API interactions @@ -10,27 +8,27 @@ module Discord.Internal.Rest.Voice ) where -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types instance Request (VoiceRequest a) where - majorRoute = voiceMajorRoute + majorRoute = voiceMajorRoute jsonRequest = voiceJsonRequest -- | Data constructor for requests. See data VoiceRequest a where - ListVoiceRegions :: VoiceRequest [VoiceRegion] + ListVoiceRegions ::VoiceRequest [VoiceRegion] voiceMajorRoute :: VoiceRequest a -> String voiceMajorRoute c = case c of - (ListVoiceRegions) -> "whatever " + ListVoiceRegions -> "whatever " voices :: R.Url 'R.Https voices = baseUrl /: "voice" voiceJsonRequest :: VoiceRequest r -> JsonRequest voiceJsonRequest c = case c of - (ListVoiceRegions) -> Get (voices /: "regions") mempty + ListVoiceRegions -> Get (voices /: "regions") mempty diff --git a/src/Discord/Internal/Rest/Webhook.hs b/src/Discord/Internal/Rest/Webhook.hs index 2bcb7bbd..1952db88 100644 --- a/src/Discord/Internal/Rest/Webhook.hs +++ b/src/Discord/Internal/Rest/Webhook.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,74 +13,88 @@ module Discord.Internal.Rest.Webhook ) where import Data.Aeson -import qualified Data.Text as T -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import Network.HTTP.Client (RequestBody (RequestBodyBS)) -import Network.HTTP.Client.MultipartFormData (partBS, partFileRequestBody) - -import Discord.Internal.Rest.Prelude -import Discord.Internal.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Network.HTTP.Client ( RequestBody(RequestBodyBS) ) +import Network.HTTP.Client.MultipartFormData + ( partBS + , partFileRequestBody + ) +import Network.HTTP.Req ( (/:) ) +import qualified Network.HTTP.Req as R + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types -- aeson introduced type name for json key (text) -- https://github.com/haskell/aeson/issues/881 -# if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.Key as Key -toKey :: T.Text -> Key.Key -toKey = Key.fromText -# else +-- # if MIN_VERSION_aeson(2, 0, 0) +-- import qualified Data.Aeson.Key as Key +-- toKey :: T.Text -> Key.Key +-- toKey = Key.fromText +-- # else toKey :: T.Text -> T.Text toKey = id -# endif +-- # endif instance Request (WebhookRequest a) where - majorRoute = webhookMajorRoute + majorRoute = webhookMajorRoute jsonRequest = webhookJsonRequest -- | Data constructor for requests. See data WebhookRequest a where - CreateWebhook :: ChannelId -> CreateWebhookOpts -> WebhookRequest Webhook - GetChannelWebhooks :: ChannelId -> WebhookRequest [Webhook] - GetGuildWebhooks :: GuildId -> WebhookRequest [Webhook] - GetWebhook :: WebhookId -> WebhookRequest Webhook - GetWebhookWithToken :: WebhookId -> T.Text -> WebhookRequest Webhook - ModifyWebhook :: WebhookId -> ModifyWebhookOpts + CreateWebhook ::ChannelId -> CreateWebhookOpts -> WebhookRequest Webhook + GetChannelWebhooks ::ChannelId -> WebhookRequest [Webhook] + GetGuildWebhooks ::GuildId -> WebhookRequest [Webhook] + GetWebhook ::WebhookId -> WebhookRequest Webhook + GetWebhookWithToken ::WebhookId -> T.Text -> WebhookRequest Webhook + ModifyWebhook ::WebhookId -> ModifyWebhookOpts -> WebhookRequest Webhook - ModifyWebhookWithToken :: WebhookId -> T.Text -> ModifyWebhookOpts + ModifyWebhookWithToken ::WebhookId -> T.Text -> ModifyWebhookOpts -> WebhookRequest Webhook - DeleteWebhook :: WebhookId -> WebhookRequest () - DeleteWebhookWithToken :: WebhookId -> T.Text -> WebhookRequest () - ExecuteWebhookWithToken :: WebhookId -> T.Text -> ExecuteWebhookWithTokenOpts + DeleteWebhook ::WebhookId -> WebhookRequest () + DeleteWebhookWithToken ::WebhookId -> T.Text -> WebhookRequest () + ExecuteWebhookWithToken ::WebhookId -> T.Text -> ExecuteWebhookWithTokenOpts -> WebhookRequest () data ModifyWebhookOpts = ModifyWebhookOpts - { modifyWebhookOptsName :: Maybe T.Text - , modifyWebhookOptsAvatar :: Maybe T.Text - , modifyWebhookOptsChannelId :: Maybe ChannelId - } deriving (Show, Read, Eq, Ord) + { modifyWebhookOptsName :: Maybe T.Text + , modifyWebhookOptsAvatar :: Maybe T.Text + , modifyWebhookOptsChannelId :: Maybe ChannelId + } + deriving (Show, Read, Eq, Ord) instance ToJSON ModifyWebhookOpts where - toJSON ModifyWebhookOpts{..} = object [(toKey name, val) | (name, Just val) <- - [("channel_id", toJSON <$> modifyWebhookOptsChannelId), - ("name", toJSON <$> modifyWebhookOptsName), - ("avatar", toJSON <$> modifyWebhookOptsAvatar) ] ] + toJSON ModifyWebhookOpts {..} = object + [ (toKey name, val) + | (name, Just val) <- + [ ("channel_id", toJSON <$> modifyWebhookOptsChannelId) + , ("name" , toJSON <$> modifyWebhookOptsName) + , ("avatar" , toJSON <$> modifyWebhookOptsAvatar) + ] + ] data CreateWebhookOpts = CreateWebhookOpts - { createWebhookOptsName :: T.Text - , createWebhookOptsAvatar :: Maybe T.Text - } deriving (Show, Read, Eq, Ord) + { createWebhookOptsName :: T.Text + , createWebhookOptsAvatar :: Maybe T.Text + } + deriving (Show, Read, Eq, Ord) instance ToJSON CreateWebhookOpts where - toJSON CreateWebhookOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> Just createWebhookOptsName), - ("avatar", toJSON <$> createWebhookOptsAvatar) ] ] + toJSON CreateWebhookOpts {..} = object + [ (name, val) + | (name, Just val) <- + [ ("name" , toJSON <$> Just createWebhookOptsName) + , ("avatar", toJSON <$> createWebhookOptsAvatar) + ] + ] data ExecuteWebhookWithTokenOpts = ExecuteWebhookWithTokenOpts - { executeWebhookWithTokenOptsUsername :: Maybe T.Text - , executeWebhookWithTokenOptsContent :: WebhookContent - } deriving (Show, Read, Eq, Ord) + { executeWebhookWithTokenOptsUsername :: Maybe T.Text + , executeWebhookWithTokenOptsContent :: WebhookContent + } + deriving (Show, Read, Eq, Ord) data WebhookContent = WebhookContentText T.Text | WebhookContentFile T.Text B.ByteString @@ -91,76 +103,85 @@ data WebhookContent = WebhookContentText T.Text webhookContentJson :: WebhookContent -> [(T.Text, Maybe Value)] webhookContentJson c = case c of - WebhookContentText t -> [("content", Just (toJSON t))] - WebhookContentFile _ _ -> [] - WebhookContentEmbeds e -> [("embeds", Just (toJSON (createEmbed <$> e)))] + WebhookContentText t -> [("content", Just (toJSON t))] + WebhookContentFile _ _ -> [] + WebhookContentEmbeds e -> [("embeds", Just (toJSON (createEmbed <$> e)))] instance ToJSON ExecuteWebhookWithTokenOpts where - toJSON ExecuteWebhookWithTokenOpts{..} = object $ [(toKey name, val) | (name, Just val) <- - [("username", toJSON <$> executeWebhookWithTokenOptsUsername)] - <> webhookContentJson executeWebhookWithTokenOptsContent - ] + toJSON ExecuteWebhookWithTokenOpts {..} = + object + $ [ (toKey name, val) + | (name, Just val) <- + [("username", toJSON <$> executeWebhookWithTokenOptsUsername)] + <> webhookContentJson executeWebhookWithTokenOptsContent + ] webhookMajorRoute :: WebhookRequest a -> String webhookMajorRoute ch = case ch of - (CreateWebhook c _) -> "aaaaaahook " <> show c - (GetChannelWebhooks c) -> "aaaaaahook " <> show c - (GetGuildWebhooks g) -> "aaaaaahook " <> show g - (GetWebhook w) -> "aaaaaahook " <> show w - (GetWebhookWithToken w _) -> "getwebhook " <> show w - (ModifyWebhook w _) -> "modifyhook " <> show w - (ModifyWebhookWithToken w _ _) -> "modifyhook " <> show w - (DeleteWebhook w) -> "deletehook " <> show w - (DeleteWebhookWithToken w _) -> "deletehook " <> show w + (CreateWebhook c _ ) -> "aaaaaahook " <> show c + (GetChannelWebhooks c ) -> "aaaaaahook " <> show c + (GetGuildWebhooks g ) -> "aaaaaahook " <> show g + (GetWebhook w ) -> "aaaaaahook " <> show w + (GetWebhookWithToken w _ ) -> "getwebhook " <> show w + (ModifyWebhook w _ ) -> "modifyhook " <> show w + (ModifyWebhookWithToken w _ _ ) -> "modifyhook " <> show w + (DeleteWebhook w ) -> "deletehook " <> show w + (DeleteWebhookWithToken w _ ) -> "deletehook " <> show w (ExecuteWebhookWithToken w _ _) -> "executehk " <> show w webhookJsonRequest :: WebhookRequest r -> JsonRequest webhookJsonRequest ch = case ch of (CreateWebhook channel patch) -> let body = pure (R.ReqBodyJson patch) - in Post (baseUrl /: "channels" // channel /: "webhooks") body mempty + in Post (baseUrl /: "channels" // channel /: "webhooks") body mempty (GetChannelWebhooks c) -> - Get (baseUrl /: "channels" // c /: "webhooks") mempty + Get (baseUrl /: "channels" // c /: "webhooks") mempty - (GetGuildWebhooks g) -> - Get (baseUrl /: "guilds" // g /: "webhooks") mempty + (GetGuildWebhooks g) -> Get (baseUrl /: "guilds" // g /: "webhooks") mempty - (GetWebhook w) -> - Get (baseUrl /: "webhooks" // w) mempty + (GetWebhook w) -> Get (baseUrl /: "webhooks" // w) mempty - (GetWebhookWithToken w t) -> - Get (baseUrl /: "webhooks" // w /: t) mempty + (GetWebhookWithToken w t) -> Get (baseUrl /: "webhooks" // w /: t) mempty (ModifyWebhook w patch) -> - Patch (baseUrl /: "webhooks" // w) (pure (R.ReqBodyJson patch)) mempty + Patch (baseUrl /: "webhooks" // w) (pure (R.ReqBodyJson patch)) mempty (ModifyWebhookWithToken w t p) -> - Patch (baseUrl /: "webhooks" // w /: t) (pure (R.ReqBodyJson p)) mempty + Patch (baseUrl /: "webhooks" // w /: t) (pure (R.ReqBodyJson p)) mempty - (DeleteWebhook w) -> - Delete (baseUrl /: "webhooks" // w) mempty + (DeleteWebhook w) -> Delete (baseUrl /: "webhooks" // w) mempty (DeleteWebhookWithToken w t) -> - Delete (baseUrl /: "webhooks" // w /: t) mempty + Delete (baseUrl /: "webhooks" // w /: t) mempty (ExecuteWebhookWithToken w tok o) -> case executeWebhookWithTokenOptsContent o of - WebhookContentFile name text -> - let part = partFileRequestBody "file" (T.unpack name) (RequestBodyBS text) + WebhookContentFile name text -> + let part = + partFileRequestBody "file" (T.unpack name) (RequestBodyBS text) body = R.reqBodyMultipart [part] - in Post (baseUrl /: "webhooks" // w /: tok) body mempty + in Post (baseUrl /: "webhooks" // w /: tok) body mempty WebhookContentText _ -> let body = pure (R.ReqBodyJson o) - in Post (baseUrl /: "webhooks" // w /: tok) body mempty + in Post (baseUrl /: "webhooks" // w /: tok) body mempty WebhookContentEmbeds embeds -> - let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) - uploads CreateEmbed{..} = [(n,c) | (n, Just (CreateEmbedImageUpload c)) <- - [ ("author.png", createEmbedAuthorIcon) - , ("thumbnail.png", createEmbedThumbnail) - , ("image.png", createEmbedImage) - , ("footer.png", createEmbedFooterIcon) ]] - parts = map mkPart (concatMap uploads embeds) - partsJson = [partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["embed" .= createEmbed e] | e <- embeds] + let mkPart (name, content) = + partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed {..} = + [ (n, c) + | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png" , createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png" , createEmbedImage) + , ("footer.png" , createEmbedFooterIcon) + ] + ] + parts = map mkPart (concatMap uploads embeds) + partsJson = + [ partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object + ["embed" .= createEmbed e] + | e <- embeds + ] body = R.reqBodyMultipart (partsJson ++ parts) - in Post (baseUrl /: "webhooks" // w /: tok) body mempty + in Post (baseUrl /: "webhooks" // w /: tok) body mempty diff --git a/src/Discord/Internal/Types.hs b/src/Discord/Internal/Types.hs index 4402a4ec..2e135c16 100644 --- a/src/Discord/Internal/Types.hs +++ b/src/Discord/Internal/Types.hs @@ -1,71 +1,72 @@ -- | Re-export ALL the internal type modules. Hiding is in Discord.Types module Discord.Internal.Types - ( module Discord.Internal.Types.Prelude, - module Discord.Internal.Types.Channel, - module Discord.Internal.Types.Color, - module Discord.Internal.Types.Events, - module Discord.Internal.Types.Gateway, - module Discord.Internal.Types.Guild, - module Discord.Internal.Types.User, - module Discord.Internal.Types.Embed, - module Discord.Internal.Types.Components, - module Discord.Internal.Types.Emoji, - module Data.Aeson, - module Data.Time.Clock, - userFacingEvent, - ) -where + ( module Discord.Internal.Types.Prelude + , module Discord.Internal.Types.Channel + , module Discord.Internal.Types.Color + , module Discord.Internal.Types.Events + , module Discord.Internal.Types.Gateway + , module Discord.Internal.Types.Guild + , module Discord.Internal.Types.User + , module Discord.Internal.Types.Embed + , module Discord.Internal.Types.Components + , module Discord.Internal.Types.Emoji + , module Data.Aeson + , module Data.Time.Clock + , userFacingEvent + ) where -import Data.Aeson (Object, ToJSON (toJSON)) -import Data.Time.Clock (UTCTime (..)) -import Discord.Internal.Types.Channel -import Discord.Internal.Types.Color -import Discord.Internal.Types.Components -import Discord.Internal.Types.Embed -import Discord.Internal.Types.Emoji -import Discord.Internal.Types.Events -import Discord.Internal.Types.Gateway -import Discord.Internal.Types.Guild -import Discord.Internal.Types.Prelude -import Discord.Internal.Types.User +import Data.Aeson ( Object + , ToJSON(toJSON) + ) +import Data.Time.Clock ( UTCTime(..) ) +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Color +import Discord.Internal.Types.Components +import Discord.Internal.Types.Embed +import Discord.Internal.Types.Emoji +import Discord.Internal.Types.Events +import Discord.Internal.Types.Gateway +import Discord.Internal.Types.Guild +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User userFacingEvent :: EventInternalParse -> Event userFacingEvent event = case event of - InternalReady a b c d e f g -> Ready a b c d e f g - InternalResumed a -> Resumed a - InternalChannelCreate a -> ChannelCreate a - InternalChannelUpdate a -> ChannelUpdate a - InternalChannelDelete a -> ChannelDelete a - InternalThreadCreate a -> ThreadCreate a - InternalThreadUpdate a -> ThreadUpdate a - InternalThreadDelete a -> ThreadDelete a - InternalThreadListSync a -> ThreadListSync a - InternalThreadMembersUpdate a -> ThreadMembersUpdate a - InternalChannelPinsUpdate a b -> ChannelPinsUpdate a b - InternalGuildCreate a -> GuildCreate a - InternalGuildUpdate a -> GuildUpdate a - InternalGuildDelete a -> GuildDelete a - InternalGuildBanAdd a b -> GuildBanAdd a b - InternalGuildBanRemove a b -> GuildBanRemove a b - InternalGuildEmojiUpdate a b -> GuildEmojiUpdate a b - InternalGuildIntegrationsUpdate a -> GuildIntegrationsUpdate a - InternalGuildMemberAdd a b -> GuildMemberAdd a b - InternalGuildMemberRemove a b -> GuildMemberRemove a b - InternalGuildMemberUpdate a b c d -> GuildMemberUpdate a b c d - InternalGuildMemberChunk a b -> GuildMemberChunk a b - InternalGuildRoleCreate a b -> GuildRoleCreate a b - InternalGuildRoleUpdate a b -> GuildRoleUpdate a b - InternalGuildRoleDelete a b -> GuildRoleDelete a b - InternalMessageCreate a -> MessageCreate a - InternalMessageUpdate a b -> MessageUpdate a b - InternalMessageDelete a b -> MessageDelete a b - InternalMessageDeleteBulk a b -> MessageDeleteBulk a b - InternalMessageReactionAdd a -> MessageReactionAdd a - InternalMessageReactionRemove a -> MessageReactionRemove a + InternalReady a b c d e f g -> Ready a b c d e f g + InternalResumed a -> Resumed a + InternalChannelCreate a -> ChannelCreate a + InternalChannelUpdate a -> ChannelUpdate a + InternalChannelDelete a -> ChannelDelete a + InternalThreadCreate a -> ThreadCreate a + InternalThreadUpdate a -> ThreadUpdate a + InternalThreadDelete a -> ThreadDelete a + InternalThreadListSync a -> ThreadListSync a + InternalThreadMembersUpdate a -> ThreadMembersUpdate a + InternalChannelPinsUpdate a b -> ChannelPinsUpdate a b + InternalGuildCreate a -> GuildCreate a + InternalGuildUpdate a -> GuildUpdate a + InternalGuildDelete a -> GuildDelete a + InternalGuildBanAdd a b -> GuildBanAdd a b + InternalGuildBanRemove a b -> GuildBanRemove a b + InternalGuildEmojiUpdate a b -> GuildEmojiUpdate a b + InternalGuildIntegrationsUpdate a -> GuildIntegrationsUpdate a + InternalGuildMemberAdd a b -> GuildMemberAdd a b + InternalGuildMemberRemove a b -> GuildMemberRemove a b + InternalGuildMemberUpdate a b c d -> GuildMemberUpdate a b c d + InternalGuildMemberChunk a b -> GuildMemberChunk a b + InternalGuildRoleCreate a b -> GuildRoleCreate a b + InternalGuildRoleUpdate a b -> GuildRoleUpdate a b + InternalGuildRoleDelete a b -> GuildRoleDelete a b + InternalMessageCreate a -> MessageCreate a + InternalMessageUpdate a b -> MessageUpdate a b + InternalMessageDelete a b -> MessageDelete a b + InternalMessageDeleteBulk a b -> MessageDeleteBulk a b + InternalMessageReactionAdd a -> MessageReactionAdd a + InternalMessageReactionRemove a -> MessageReactionRemove a InternalMessageReactionRemoveAll a b -> MessageReactionRemoveAll a b InternalMessageReactionRemoveEmoji a -> MessageReactionRemoveEmoji a - InternalPresenceUpdate a -> PresenceUpdate a - InternalTypingStart a -> TypingStart a - InternalUserUpdate a -> UserUpdate a - InternalInteractionCreate a -> InteractionCreate a - InternalUnknownEvent a b -> UnknownEvent a b + InternalPresenceUpdate a -> PresenceUpdate a + InternalTypingStart a -> TypingStart a + InternalUserUpdate a -> UserUpdate a + InternalInteractionCreate a -> InteractionCreate a + InternalUnknownEvent a b -> UnknownEvent a b diff --git a/src/Discord/Internal/Types/ApplicationCommands.hs b/src/Discord/Internal/Types/ApplicationCommands.hs index 2157ea03..daaa262a 100644 --- a/src/Discord/Internal/Types/ApplicationCommands.hs +++ b/src/Discord/Internal/Types/ApplicationCommands.hs @@ -9,31 +9,39 @@ {-# LANGUAGE RecordWildCards #-} module Discord.Internal.Types.ApplicationCommands - ( ApplicationCommand (..), - ApplicationCommandOptions (..), - ApplicationCommandOptionSubcommandOrGroup (..), - ApplicationCommandOptionSubcommand (..), - ApplicationCommandOptionValue (..), - createApplicationCommandChatInput, - createApplicationCommandUser, - createApplicationCommandMessage, - CreateApplicationCommand (..), - EditApplicationCommand (..), - defaultEditApplicationCommand, - Choice (..), - ApplicationCommandChannelType (..), - GuildApplicationCommandPermissions (..), - ApplicationCommandPermissions (..), - ) -where - -import Data.Aeson -import Data.Aeson.Types (Pair, Parser) -import Data.Data (Data) -import Data.Foldable (Foldable (toList)) -import Data.Scientific (Scientific) -import qualified Data.Text as T -import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, InternalDiscordEnum (..), Snowflake, discordTypeParseJSON, toMaybeJSON) + ( ApplicationCommand(..) + , ApplicationCommandOptions(..) + , ApplicationCommandOptionSubcommandOrGroup(..) + , ApplicationCommandOptionSubcommand(..) + , ApplicationCommandOptionValue(..) + , createApplicationCommandChatInput + , createApplicationCommandUser + , createApplicationCommandMessage + , CreateApplicationCommand(..) + , EditApplicationCommand(..) + , defaultEditApplicationCommand + , Choice(..) + , ApplicationCommandChannelType(..) + , GuildApplicationCommandPermissions(..) + , ApplicationCommandPermissions(..) + ) where + +import Data.Aeson +import Data.Aeson.Types ( Pair + , Parser + ) +import Data.Data ( Data ) +import Data.Foldable ( Foldable(toList) ) +import Data.Scientific ( Scientific ) +import qualified Data.Text as T +import Discord.Internal.Types.Prelude ( ApplicationCommandId + , ApplicationId + , GuildId + , InternalDiscordEnum(..) + , Snowflake + , discordTypeParseJSON + , toMaybeJSON + ) -- | The structure for an application command. data ApplicationCommand @@ -86,25 +94,33 @@ data ApplicationCommand deriving (Show, Eq, Read) instance FromJSON ApplicationCommand where - parseJSON = - withObject - "ApplicationCommand" - ( \v -> do - acid <- v .: "id" - aid <- v .: "application_id" - gid <- v .:? "guild_id" - name <- v .: "name" - defPerm <- v .:? "default_permission" .!= True - version <- v .: "version" - t <- v .:? "type" :: Parser (Maybe Int) - case t of - (Just 2) -> return $ ApplicationCommandUser acid aid gid name defPerm version - (Just 3) -> return $ ApplicationCommandMessage acid aid gid name defPerm version - _ -> do - desc <- v .: "description" - options <- v .:? "options" - return $ ApplicationCommandChatInput acid aid gid name desc options defPerm version - ) + parseJSON = withObject + "ApplicationCommand" + (\v -> do + acid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + name <- v .: "name" + defPerm <- v .:? "default_permission" .!= True + version <- v .: "version" + t <- v .:? "type" :: Parser (Maybe Int) + case t of + (Just 2) -> + return $ ApplicationCommandUser acid aid gid name defPerm version + (Just 3) -> + return $ ApplicationCommandMessage acid aid gid name defPerm version + _ -> do + desc <- v .: "description" + options <- v .:? "options" + return $ ApplicationCommandChatInput acid + aid + gid + name + desc + options + defPerm + version + ) -- | Either subcommands and groups, or values. data ApplicationCommandOptions @@ -113,28 +129,26 @@ data ApplicationCommandOptions deriving (Show, Eq, Read) instance FromJSON ApplicationCommandOptions where - parseJSON = - withArray - "ApplicationCommandOptions" - ( \a -> do - let a' = toList a - case a' of - [] -> return $ ApplicationCommandOptionsValues [] - (v' : _) -> - withObject - "ApplicationCommandOptions item" - ( \v -> do - t <- v .: "type" :: Parser Int - if t == 1 || t == 2 - then ApplicationCommandOptionsSubcommands <$> mapM parseJSON a' - else ApplicationCommandOptionsValues <$> mapM parseJSON a' - ) - v' - ) + parseJSON = withArray + "ApplicationCommandOptions" + (\a -> do + let a' = toList a + case a' of + [] -> return $ ApplicationCommandOptionsValues [] + (v' : _) -> withObject + "ApplicationCommandOptions item" + (\v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then ApplicationCommandOptionsSubcommands <$> mapM parseJSON a' + else ApplicationCommandOptionsValues <$> mapM parseJSON a' + ) + v' + ) instance ToJSON ApplicationCommandOptions where toJSON (ApplicationCommandOptionsSubcommands o) = toJSON o - toJSON (ApplicationCommandOptionsValues o) = toJSON o + toJSON (ApplicationCommandOptionsValues o) = toJSON o -- | Either a subcommand group or a subcommand. data ApplicationCommandOptionSubcommandOrGroup @@ -150,65 +164,71 @@ data ApplicationCommandOptionSubcommandOrGroup deriving (Show, Eq, Read) instance FromJSON ApplicationCommandOptionSubcommandOrGroup where - parseJSON = - withObject - "ApplicationCommandOptionSubcommandOrGroup" - ( \v -> do - t <- v .: "type" :: Parser Int - case t of - 2 -> - ApplicationCommandOptionSubcommandGroup - <$> v .: "name" - <*> v .: "description" - <*> v .: "options" - 1 -> ApplicationCommandOptionSubcommandOrGroupSubcommand <$> parseJSON (Object v) - _ -> fail "unexpected subcommand group type" - ) + parseJSON = withObject + "ApplicationCommandOptionSubcommandOrGroup" + (\v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + ApplicationCommandOptionSubcommandGroup + <$> v + .: "name" + <*> v + .: "description" + <*> v + .: "options" + 1 -> ApplicationCommandOptionSubcommandOrGroupSubcommand + <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) instance ToJSON ApplicationCommandOptionSubcommandOrGroup where - toJSON ApplicationCommandOptionSubcommandGroup {..} = - object - [ ("type", Number 2), - ("name", toJSON applicationCommandOptionSubcommandGroupName), - ("description", toJSON applicationCommandOptionSubcommandGroupDescription), - ("options", toJSON applicationCommandOptionSubcommandGroupOptions) - ] + toJSON ApplicationCommandOptionSubcommandGroup {..} = object + [ ("type" , Number 2) + , ("name", toJSON applicationCommandOptionSubcommandGroupName) + , ("description", toJSON applicationCommandOptionSubcommandGroupDescription) + , ("options", toJSON applicationCommandOptionSubcommandGroupOptions) + ] toJSON (ApplicationCommandOptionSubcommandOrGroupSubcommand a) = toJSON a -- | Data for a single subcommand. data ApplicationCommandOptionSubcommand = ApplicationCommandOptionSubcommand { -- | The name of the subcommand - applicationCommandOptionSubcommandName :: T.Text, + applicationCommandOptionSubcommandName :: T.Text + , -- | The description of the subcommand - applicationCommandOptionSubcommandDescription :: T.Text, + applicationCommandOptionSubcommandDescription :: T.Text + , -- | What options are there in this subcommand applicationCommandOptionSubcommandOptions :: [ApplicationCommandOptionValue] } deriving (Show, Eq, Read) instance FromJSON ApplicationCommandOptionSubcommand where - parseJSON = - withObject - "ApplicationCommandOptionSubcommand" - ( \v -> do - t <- v .: "type" :: Parser Int - case t of - 1 -> - ApplicationCommandOptionSubcommand - <$> v .: "name" - <*> v .: "description" - <*> v .:? "options" .!= [] - _ -> fail "unexpected subcommand type" - ) + parseJSON = withObject + "ApplicationCommandOptionSubcommand" + (\v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + ApplicationCommandOptionSubcommand + <$> v + .: "name" + <*> v + .: "description" + <*> v + .:? "options" + .!= [] + _ -> fail "unexpected subcommand type" + ) instance ToJSON ApplicationCommandOptionSubcommand where - toJSON ApplicationCommandOptionSubcommand {..} = - object - [ ("type", Number 1), - ("name", toJSON applicationCommandOptionSubcommandName), - ("description", toJSON applicationCommandOptionSubcommandDescription), - ("options", toJSON applicationCommandOptionSubcommandOptions) - ] + toJSON ApplicationCommandOptionSubcommand {..} = object + [ ("type" , Number 1) + , ("name", toJSON applicationCommandOptionSubcommandName) + , ("description", toJSON applicationCommandOptionSubcommandDescription) + , ("options", toJSON applicationCommandOptionSubcommandOptions) + ] -- | Data for a single value. data ApplicationCommandOptionValue @@ -295,84 +315,83 @@ data ApplicationCommandOptionValue deriving (Show, Eq, Read) instance FromJSON ApplicationCommandOptionValue where - parseJSON = - withObject - "ApplicationCommandOptionValue" - ( \v -> do - name <- v .: "name" - desc <- v .: "description" - required <- v .:? "required" .!= False - t <- v .: "type" :: Parser Int - case t of - 3 -> - ApplicationCommandOptionValueString name desc required - <$> parseJSON (Object v) - 4 -> - ApplicationCommandOptionValueInteger name desc required - <$> parseJSON (Object v) - <*> v .:? "min_value" - <*> v .:? "max_value" - 10 -> - ApplicationCommandOptionValueNumber name desc required - <$> parseJSON (Object v) - <*> v .:? "min_value" - <*> v .:? "max_value" - 7 -> - ApplicationCommandOptionValueChannel name desc required - <$> v .:? "channel_types" - 5 -> return $ ApplicationCommandOptionValueBoolean name desc required - 6 -> return $ ApplicationCommandOptionValueUser name desc required - 8 -> return $ ApplicationCommandOptionValueRole name desc required - 9 -> return $ ApplicationCommandOptionValueMentionable name desc required - _ -> fail "unknown application command option value type" - ) + parseJSON = withObject + "ApplicationCommandOptionValue" + (\v -> do + name <- v .: "name" + desc <- v .: "description" + required <- v .:? "required" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> ApplicationCommandOptionValueString name desc required + <$> parseJSON (Object v) + 4 -> + ApplicationCommandOptionValueInteger name desc required + <$> parseJSON (Object v) + <*> v + .:? "min_value" + <*> v + .:? "max_value" + 10 -> + ApplicationCommandOptionValueNumber name desc required + <$> parseJSON (Object v) + <*> v + .:? "min_value" + <*> v + .:? "max_value" + 7 -> + ApplicationCommandOptionValueChannel name desc required + <$> v + .:? "channel_types" + 5 -> return $ ApplicationCommandOptionValueBoolean name desc required + 6 -> return $ ApplicationCommandOptionValueUser name desc required + 8 -> return $ ApplicationCommandOptionValueRole name desc required + 9 -> + return $ ApplicationCommandOptionValueMentionable name desc required + _ -> fail "unknown application command option value type" + ) instance ToJSON ApplicationCommandOptionValue where - toJSON ApplicationCommandOptionValueString {..} = - object - [ ("type", Number 3), - ("name", toJSON applicationCommandOptionValueName), - ("description", toJSON applicationCommandOptionValueDescription), - ("required", toJSON applicationCommandOptionValueRequired), - choiceOrAutocompleteToJSON applicationCommandOptionValueStringChoices - ] - toJSON ApplicationCommandOptionValueInteger {..} = - object - [ ("type", Number 4), - ("name", toJSON applicationCommandOptionValueName), - ("description", toJSON applicationCommandOptionValueDescription), - ("required", toJSON applicationCommandOptionValueRequired), - choiceOrAutocompleteToJSON applicationCommandOptionValueIntegerChoices - ] - toJSON ApplicationCommandOptionValueNumber {..} = - object - [ ("type", Number 10), - ("name", toJSON applicationCommandOptionValueName), - ("description", toJSON applicationCommandOptionValueDescription), - ("required", toJSON applicationCommandOptionValueRequired), - choiceOrAutocompleteToJSON applicationCommandOptionValueNumberChoices - ] - toJSON ApplicationCommandOptionValueChannel {..} = - object - [ ("type", Number 7), - ("name", toJSON applicationCommandOptionValueName), - ("description", toJSON applicationCommandOptionValueDescription), - ("required", toJSON applicationCommandOptionValueRequired), - ("channel_types", toJSON applicationCommandOptionValueChannelTypes) - ] - toJSON acov = - object - [ ("type", Number (t acov)), - ("name", toJSON $ applicationCommandOptionValueName acov), - ("description", toJSON $ applicationCommandOptionValueDescription acov), - ("required", toJSON $ applicationCommandOptionValueRequired acov) - ] - where - t ApplicationCommandOptionValueBoolean {} = 5 - t ApplicationCommandOptionValueUser {} = 6 - t ApplicationCommandOptionValueRole {} = 8 - t ApplicationCommandOptionValueMentionable {} = 9 - t _ = -1 + toJSON ApplicationCommandOptionValueString {..} = object + [ ("type" , Number 3) + , ("name", toJSON applicationCommandOptionValueName) + , ("description", toJSON applicationCommandOptionValueDescription) + , ("required", toJSON applicationCommandOptionValueRequired) + , choiceOrAutocompleteToJSON applicationCommandOptionValueStringChoices + ] + toJSON ApplicationCommandOptionValueInteger {..} = object + [ ("type" , Number 4) + , ("name", toJSON applicationCommandOptionValueName) + , ("description", toJSON applicationCommandOptionValueDescription) + , ("required", toJSON applicationCommandOptionValueRequired) + , choiceOrAutocompleteToJSON applicationCommandOptionValueIntegerChoices + ] + toJSON ApplicationCommandOptionValueNumber {..} = object + [ ("type" , Number 10) + , ("name", toJSON applicationCommandOptionValueName) + , ("description", toJSON applicationCommandOptionValueDescription) + , ("required", toJSON applicationCommandOptionValueRequired) + , choiceOrAutocompleteToJSON applicationCommandOptionValueNumberChoices + ] + toJSON ApplicationCommandOptionValueChannel {..} = object + [ ("type" , Number 7) + , ("name", toJSON applicationCommandOptionValueName) + , ("description", toJSON applicationCommandOptionValueDescription) + , ("required", toJSON applicationCommandOptionValueRequired) + , ("channel_types", toJSON applicationCommandOptionValueChannelTypes) + ] + toJSON acov = object + [ ("type" , Number (t acov)) + , ("name", toJSON $ applicationCommandOptionValueName acov) + , ("description", toJSON $ applicationCommandOptionValueDescription acov) + , ("required", toJSON $ applicationCommandOptionValueRequired acov) + ] + where + t ApplicationCommandOptionValueBoolean{} = 5 + t ApplicationCommandOptionValueUser{} = 6 + t ApplicationCommandOptionValueRole{} = 8 + t ApplicationCommandOptionValueMentionable{} = 9 + t _ = -1 -- | Data type to be used when creating application commands. The specification -- is below. @@ -421,64 +440,71 @@ data CreateApplicationCommand deriving (Show, Eq, Read) instance ToJSON CreateApplicationCommand where - toJSON CreateApplicationCommandChatInput {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toMaybeJSON createApplicationCommandName), - ("description", toMaybeJSON createApplicationCommandDescription), - ("options", toJSON <$> createApplicationCommandOptions), - ("default_permission", toMaybeJSON createApplicationCommandDefaultPermission), - ("type", Just $ Number 1) - ] + toJSON CreateApplicationCommandChatInput {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name" , toMaybeJSON createApplicationCommandName) + , ("description", toMaybeJSON createApplicationCommandDescription) + , ("options" , toJSON <$> createApplicationCommandOptions) + , ( "default_permission" + , toMaybeJSON createApplicationCommandDefaultPermission + ) + , ("type", Just $ Number 1) ] - toJSON CreateApplicationCommandUser {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toMaybeJSON createApplicationCommandName), - ("default_permission", toMaybeJSON createApplicationCommandDefaultPermission), - ("type", Just $ Number 2) - ] + ] + toJSON CreateApplicationCommandUser {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name", toMaybeJSON createApplicationCommandName) + , ( "default_permission" + , toMaybeJSON createApplicationCommandDefaultPermission + ) + , ("type", Just $ Number 2) ] - toJSON CreateApplicationCommandMessage {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toMaybeJSON createApplicationCommandName), - ("default_permission", toMaybeJSON createApplicationCommandDefaultPermission), - ("type", Just $ Number 3) - ] + ] + toJSON CreateApplicationCommandMessage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name", toMaybeJSON createApplicationCommandName) + , ( "default_permission" + , toMaybeJSON createApplicationCommandDefaultPermission + ) + , ("type", Just $ Number 3) ] + ] nameIsValid :: Bool -> T.Text -> Bool -nameIsValid isChatInput name = l >= 1 && l <= 32 && (isChatInput <= T.all (`elem` validChars) name) - where - l = T.length name - validChars = '-' : ['a' .. 'z'] +nameIsValid isChatInput name = + l >= 1 && l <= 32 && (isChatInput <= T.all (`elem` validChars) name) + where + l = T.length name + validChars = '-' : ['a' .. 'z'] -- | Create the basics for a chat input (slash command). Use record overwriting -- to enter the other values. The name needs to be all lower case letters, and -- between 1 and 32 characters. The description has to be non-empty and less -- than or equal to 100 characters. -createApplicationCommandChatInput :: T.Text -> T.Text -> Maybe CreateApplicationCommand +createApplicationCommandChatInput + :: T.Text -> T.Text -> Maybe CreateApplicationCommand createApplicationCommandChatInput name desc - | nameIsValid True name && not (T.null desc) && T.length desc <= 100 = Just $ CreateApplicationCommandChatInput name desc Nothing True - | otherwise = Nothing + | nameIsValid True name && not (T.null desc) && T.length desc <= 100 + = Just $ CreateApplicationCommandChatInput name desc Nothing True + | otherwise + = Nothing -- | Create the basics for a user command. Use record overwriting to enter the -- other values. The name needs to be between 1 and 32 characters. createApplicationCommandUser :: T.Text -> Maybe CreateApplicationCommand createApplicationCommandUser name | nameIsValid False name = Just $ CreateApplicationCommandUser name True - | otherwise = Nothing + | otherwise = Nothing -- | Create the basics for a message command. Use record overwriting to enter -- the other values. The name needs to be between 1 and 32 characters. createApplicationCommandMessage :: T.Text -> Maybe CreateApplicationCommand createApplicationCommandMessage name | nameIsValid False name = Just $ CreateApplicationCommandMessage name True - | otherwise = Nothing + | otherwise = Nothing -- | Data type to be used when editing application commands. The specification -- is below. See `CreateApplicationCommand` for an explanation for the @@ -504,73 +530,74 @@ data EditApplicationCommand defaultEditApplicationCommand :: Int -> EditApplicationCommand defaultEditApplicationCommand 2 = EditApplicationCommandUser Nothing Nothing defaultEditApplicationCommand 3 = EditApplicationCommandMessage Nothing Nothing -defaultEditApplicationCommand _ = EditApplicationCommandChatInput Nothing Nothing Nothing Nothing +defaultEditApplicationCommand _ = + EditApplicationCommandChatInput Nothing Nothing Nothing Nothing instance ToJSON EditApplicationCommand where - toJSON EditApplicationCommandChatInput {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toJSON <$> editApplicationCommandName), - ("description", toJSON <$> editApplicationCommandDescription), - ("options", toJSON <$> editApplicationCommandOptions), - ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), - ("type", Just $ Number 1) - ] + toJSON EditApplicationCommandChatInput {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name" , toJSON <$> editApplicationCommandName) + , ("description", toJSON <$> editApplicationCommandDescription) + , ("options" , toJSON <$> editApplicationCommandOptions) + , ( "default_permission" + , toJSON <$> editApplicationCommandDefaultPermission + ) + , ("type", Just $ Number 1) ] - toJSON EditApplicationCommandUser {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toJSON <$> editApplicationCommandName), - ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), - ("type", Just $ Number 2) - ] + ] + toJSON EditApplicationCommandUser {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name", toJSON <$> editApplicationCommandName) + , ( "default_permission" + , toJSON <$> editApplicationCommandDefaultPermission + ) + , ("type", Just $ Number 2) ] - toJSON EditApplicationCommandMessage {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("name", toJSON <$> editApplicationCommandName), - ("default_permission", toJSON <$> editApplicationCommandDefaultPermission), - ("type", Just $ Number 3) - ] + ] + toJSON EditApplicationCommandMessage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("name", toJSON <$> editApplicationCommandName) + , ( "default_permission" + , toJSON <$> editApplicationCommandDefaultPermission + ) + , ("type", Just $ Number 3) ] + ] -data Choice a = Choice {choiceName :: T.Text, choiceValue :: a} +data Choice a = Choice + { choiceName :: T.Text + , choiceValue :: a + } deriving (Show, Read, Eq, Ord) instance Functor Choice where fmap f (Choice s a) = Choice s (f a) instance (ToJSON a) => ToJSON (Choice a) where - toJSON Choice {..} = object [("name", toJSON choiceName), ("value", toJSON choiceValue)] + toJSON Choice {..} = + object [("name", toJSON choiceName), ("value", toJSON choiceValue)] instance (FromJSON a) => FromJSON (Choice a) where parseJSON = - withObject - "Choice" - ( \v -> - Choice - <$> v .: "name" - <*> v .: "value" - ) + withObject "Choice" (\v -> Choice <$> v .: "name" <*> v .: "value") type AutocompleteOrChoice a = Either Bool [Choice a] instance {-# OVERLAPPING #-} (FromJSON a) => FromJSON (AutocompleteOrChoice a) where - parseJSON = - withObject - "AutocompleteOrChoice" - ( \v -> do - mcs <- v .:! "choices" - case mcs of - Nothing -> Left <$> v .:? "autocomplete" .!= False - Just cs -> return $ Right cs - ) + parseJSON = withObject + "AutocompleteOrChoice" + (\v -> do + mcs <- v .:! "choices" + case mcs of + Nothing -> Left <$> v .:? "autocomplete" .!= False + Just cs -> return $ Right cs + ) choiceOrAutocompleteToJSON :: (ToJSON a) => AutocompleteOrChoice a -> Pair -choiceOrAutocompleteToJSON (Left b) = ("autocomplete", toJSON b) +choiceOrAutocompleteToJSON (Left b ) = ("autocomplete", toJSON b) choiceOrAutocompleteToJSON (Right cs) = ("choices", toJSON cs) -- | The different channel types. @@ -604,17 +631,17 @@ data ApplicationCommandChannelType instance InternalDiscordEnum ApplicationCommandChannelType where discordTypeStartValue = ApplicationCommandChannelTypeGuildText - fromDiscordType ApplicationCommandChannelTypeGuildText = 0 - fromDiscordType ApplicationCommandChannelTypeDM = 1 - fromDiscordType ApplicationCommandChannelTypeGuildVoice = 2 - fromDiscordType ApplicationCommandChannelTypeGroupDM = 3 - fromDiscordType ApplicationCommandChannelTypeGuildCategory = 4 - fromDiscordType ApplicationCommandChannelTypeGuildNews = 5 - fromDiscordType ApplicationCommandChannelTypeGuildStore = 6 - fromDiscordType ApplicationCommandChannelTypeGuildNewsThread = 10 - fromDiscordType ApplicationCommandChannelTypeGuildPublicThread = 11 + fromDiscordType ApplicationCommandChannelTypeGuildText = 0 + fromDiscordType ApplicationCommandChannelTypeDM = 1 + fromDiscordType ApplicationCommandChannelTypeGuildVoice = 2 + fromDiscordType ApplicationCommandChannelTypeGroupDM = 3 + fromDiscordType ApplicationCommandChannelTypeGuildCategory = 4 + fromDiscordType ApplicationCommandChannelTypeGuildNews = 5 + fromDiscordType ApplicationCommandChannelTypeGuildStore = 6 + fromDiscordType ApplicationCommandChannelTypeGuildNewsThread = 10 + fromDiscordType ApplicationCommandChannelTypeGuildPublicThread = 11 fromDiscordType ApplicationCommandChannelTypeGuildPrivateThread = 12 - fromDiscordType ApplicationCommandChannelTypeGuildStageVoice = 13 + fromDiscordType ApplicationCommandChannelTypeGuildStageVoice = 13 instance ToJSON ApplicationCommandChannelType where toJSON = toJSON . fromDiscordType @@ -624,70 +651,83 @@ instance FromJSON ApplicationCommandChannelType where data GuildApplicationCommandPermissions = GuildApplicationCommandPermissions { -- | The id of the command. - guildApplicationCommandPermissionsId :: ApplicationCommandId, + guildApplicationCommandPermissionsId :: ApplicationCommandId + , -- | The id of the application. - guildApplicationCommandPermissionsApplicationId :: ApplicationId, + guildApplicationCommandPermissionsApplicationId :: ApplicationId + , -- | The id of the guild. - guildApplicationCommandPermissionsGuildId :: GuildId, + guildApplicationCommandPermissionsGuildId :: GuildId + , -- | The permissions for the command in the guild. - guildApplicationCommandPermissionsPermissions :: [ApplicationCommandPermissions] + guildApplicationCommandPermissionsPermissions + :: [ApplicationCommandPermissions] } deriving (Show, Read, Eq, Ord) instance FromJSON GuildApplicationCommandPermissions where - parseJSON = - withObject - "GuildApplicationCommandPermissions" - ( \v -> - GuildApplicationCommandPermissions - <$> v .: "id" - <*> v .: "application_id" - <*> v .: "guild_id" - <*> v .: "permissions" - ) + parseJSON = withObject + "GuildApplicationCommandPermissions" + (\v -> + GuildApplicationCommandPermissions + <$> v + .: "id" + <*> v + .: "application_id" + <*> v + .: "guild_id" + <*> v + .: "permissions" + ) instance ToJSON GuildApplicationCommandPermissions where - toJSON GuildApplicationCommandPermissions {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("id", toMaybeJSON guildApplicationCommandPermissionsId), - ("application_id", toMaybeJSON guildApplicationCommandPermissionsApplicationId), - ("guild_id", toMaybeJSON guildApplicationCommandPermissionsGuildId), - ("permissions", toMaybeJSON guildApplicationCommandPermissionsPermissions) - ] + toJSON GuildApplicationCommandPermissions {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id", toMaybeJSON guildApplicationCommandPermissionsId) + , ( "application_id" + , toMaybeJSON guildApplicationCommandPermissionsApplicationId + ) + , ("guild_id", toMaybeJSON guildApplicationCommandPermissionsGuildId) + , ( "permissions" + , toMaybeJSON guildApplicationCommandPermissionsPermissions + ) ] + ] -- | Application command permissions allow you to enable or disable commands for -- specific users or roles within a guild. data ApplicationCommandPermissions = ApplicationCommandPermissions { -- | The id of the role or user. - applicationCommandPermissionsId :: Snowflake, + applicationCommandPermissionsId :: Snowflake + , -- | Choose either role (1) or user (2). - applicationCommandPermissionsType :: Integer, + applicationCommandPermissionsType :: Integer + , -- | Whether to allow or not. applicationCommandPermissionsPermission :: Bool } deriving (Show, Read, Eq, Ord) instance FromJSON ApplicationCommandPermissions where - parseJSON = - withObject - "ApplicationCommandPermissions" - ( \v -> - ApplicationCommandPermissions - <$> v .: "id" - <*> v .: "type" - <*> v .: "permission" - ) + parseJSON = withObject + "ApplicationCommandPermissions" + (\v -> + ApplicationCommandPermissions + <$> v + .: "id" + <*> v + .: "type" + <*> v + .: "permission" + ) instance ToJSON ApplicationCommandPermissions where - toJSON ApplicationCommandPermissions {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("id", toMaybeJSON applicationCommandPermissionsId), - ("type", toMaybeJSON applicationCommandPermissionsType), - ("permission", toMaybeJSON applicationCommandPermissionsPermission) - ] + toJSON ApplicationCommandPermissions {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toMaybeJSON applicationCommandPermissionsId) + , ("type" , toMaybeJSON applicationCommandPermissionsType) + , ("permission", toMaybeJSON applicationCommandPermissionsPermission) ] + ] diff --git a/src/Discord/Internal/Types/Channel.hs b/src/Discord/Internal/Types/Channel.hs index c5aecbb6..aa5c9373 100644 --- a/src/Discord/Internal/Types/Channel.hs +++ b/src/Discord/Internal/Types/Channel.hs @@ -6,21 +6,26 @@ -- | Data structures pertaining to Discord Channels module Discord.Internal.Types.Channel where -import Control.Applicative (empty) -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Default (Default, def) -import Data.Text (Text) -import Data.Time.Clock -import qualified Data.Text as T -import Data.Bits -import Data.Data (Data) - -import Discord.Internal.Types.Prelude -import Discord.Internal.Types.User (User(..), GuildMember) -import Discord.Internal.Types.Embed -import Discord.Internal.Types.Components (ComponentActionRow) -import Discord.Internal.Types.Emoji +import Control.Applicative ( empty ) +import Data.Aeson +import Data.Aeson.Types ( Parser ) +import Data.Bits +import Data.Data ( Data ) +import Data.Default ( Default + , def + ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Time.Clock + +import Discord.Internal.Types.Components + ( ComponentActionRow ) +import Discord.Internal.Types.Embed +import Discord.Internal.Types.Emoji +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User ( GuildMember + , User(..) + ) -- | Guild channels represent an isolated set of users and messages in a Guild (Server) data Channel @@ -138,198 +143,334 @@ instance FromJSON Channel where type' <- (o .: "type") :: Parser Int case type' of 0 -> - ChannelText <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .: "permission_overwrites" - <*> o .: "rate_limit_per_user" - <*> o .:? "nsfw" .!= False - <*> o .:? "topic" .!= "" - <*> o .:? "last_message_id" - <*> o .:? "parent_id" + ChannelText + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .: "name" + <*> o + .: "position" + <*> o + .: "permission_overwrites" + <*> o + .: "rate_limit_per_user" + <*> o + .:? "nsfw" + .!= False + <*> o + .:? "topic" + .!= "" + <*> o + .:? "last_message_id" + <*> o + .:? "parent_id" 1 -> - ChannelDirectMessage <$> o .: "id" - <*> o .: "recipients" - <*> o .:? "last_message_id" + ChannelDirectMessage + <$> o + .: "id" + <*> o + .: "recipients" + <*> o + .:? "last_message_id" 2 -> - ChannelVoice <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .: "permission_overwrites" - <*> o .:? "nsfw" .!= False - <*> o .: "bitrate" - <*> o .: "user_limit" - <*> o .:? "parent_id" + ChannelVoice + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .: "name" + <*> o + .: "position" + <*> o + .: "permission_overwrites" + <*> o + .:? "nsfw" + .!= False + <*> o + .: "bitrate" + <*> o + .: "user_limit" + <*> o + .:? "parent_id" 3 -> - ChannelGroupDM <$> o .: "id" - <*> o .: "recipients" - <*> o .:? "last_message_id" + ChannelGroupDM + <$> o + .: "id" + <*> o + .: "recipients" + <*> o + .:? "last_message_id" 4 -> - ChannelGuildCategory <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .: "permission_overwrites" + ChannelGuildCategory + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .: "name" + <*> o + .: "position" + <*> o + .: "permission_overwrites" 5 -> - ChannelNews <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .: "permission_overwrites" - <*> o .:? "nsfw" .!= False - <*> o .:? "topic" .!= "" - <*> o .:? "last_message_id" + ChannelNews + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .: "name" + <*> o + .: "position" + <*> o + .: "permission_overwrites" + <*> o + .:? "nsfw" + .!= False + <*> o + .:? "topic" + .!= "" + <*> o + .:? "last_message_id" 6 -> - ChannelStorePage <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "name" - <*> o .: "position" - <*> o .:? "nsfw" .!= False - <*> o .: "permission_overwrites" - <*> o .:? "parent_id" - 10 -> ChannelNewsThread <$> o.: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .:? "name" - <*> o .:? "rate_limit_per_user" - <*> o .:? "last_message_id" - <*> o .:? "parent_id" - <*> o .:? "thread_metadata" - <*> o .:? "member" - 11 -> ChannelPublicThread <$> o.: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .:? "name" - <*> o .:? "rate_limit_per_user" - <*> o .:? "last_message_id" - <*> o .:? "parent_id" - <*> o .:? "thread_metadata" - <*> o .:? "member" - 12 -> ChannelPrivateThread <$> o.: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .:? "name" - <*> o .:? "rate_limit_per_user" - <*> o .:? "last_message_id" - <*> o .:? "parent_id" - <*> o .:? "thread_metadata" - <*> o .:? "member" + ChannelStorePage + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .: "name" + <*> o + .: "position" + <*> o + .:? "nsfw" + .!= False + <*> o + .: "permission_overwrites" + <*> o + .:? "parent_id" + 10 -> + ChannelNewsThread + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .:? "name" + <*> o + .:? "rate_limit_per_user" + <*> o + .:? "last_message_id" + <*> o + .:? "parent_id" + <*> o + .:? "thread_metadata" + <*> o + .:? "member" + 11 -> + ChannelPublicThread + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .:? "name" + <*> o + .:? "rate_limit_per_user" + <*> o + .:? "last_message_id" + <*> o + .:? "parent_id" + <*> o + .:? "thread_metadata" + <*> o + .:? "member" + 12 -> + ChannelPrivateThread + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .:? "name" + <*> o + .:? "rate_limit_per_user" + <*> o + .:? "last_message_id" + <*> o + .:? "parent_id" + <*> o + .:? "thread_metadata" + <*> o + .:? "member" 13 -> - ChannelStage <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - <*> o .: "id" - <*> o .:? "topic" .!= "" - _ -> ChannelUnknownType <$> o .: "id" - <*> pure (T.pack (show o)) + ChannelStage + <$> o + .: "id" + <*> o + .:? "guild_id" + .!= 0 + <*> o + .: "id" + <*> o + .:? "topic" + .!= "" + _ -> ChannelUnknownType <$> o .: "id" <*> pure (T.pack (show o)) instance ToJSON Channel where - toJSON ChannelText{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> pure channelName) - , ("position", toJSON <$> pure channelPosition) - , ("rate_limit_per_user", toJSON <$> pure channelUserRateLimit) - , ("nsfw", toJSON <$> pure channelNSFW) - , ("permission_overwrites", toJSON <$> pure channelPermissions) - , ("topic", toJSON <$> pure channelTopic) - , ("last_message_id", toJSON <$> channelLastMessage) - , ("parent_id", toJSON <$> pure channelParentId) - ] ] - toJSON ChannelNews{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> pure channelName) - , ("position", toJSON <$> pure channelPosition) - , ("permission_overwrites", toJSON <$> pure channelPermissions) - , ("nsfw", toJSON <$> pure channelNSFW) - , ("topic", toJSON <$> pure channelTopic) - , ("last_message_id", toJSON <$> channelLastMessage) - ] ] - toJSON ChannelStorePage{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> pure channelName) - , ("nsfw", toJSON <$> pure channelNSFW) - , ("position", toJSON <$> pure channelPosition) - , ("permission_overwrites", toJSON <$> pure channelPermissions) - ] ] - toJSON ChannelDirectMessage{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("recipients", toJSON <$> pure channelRecipients) - , ("last_message_id", toJSON <$> channelLastMessage) - ] ] - toJSON ChannelVoice{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> pure channelName) - , ("position", toJSON <$> pure channelPosition) - , ("nsfw", toJSON <$> pure channelNSFW) - , ("permission_overwrites", toJSON <$> pure channelPermissions) - , ("bitrate", toJSON <$> pure channelBitRate) - , ("user_limit", toJSON <$> pure channelUserLimit) - ] ] - toJSON ChannelGroupDM{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("recipients", toJSON <$> pure channelRecipients) - , ("last_message_id", toJSON <$> channelLastMessage) - ] ] - toJSON ChannelGuildCategory{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("name", toJSON <$> pure channelName) - , ("guild_id", toJSON <$> pure channelGuild) - ] ] - toJSON ChannelStage{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("channel_id", toJSON <$> pure channelStageId) - , ("topic", toJSON <$> pure channelStageTopic) - ] ] - toJSON ChannelNewsThread{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> channelThreadName) - , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) - , ("last_message_id", toJSON <$> channelLastMessage) - , ("parent_id", toJSON <$> pure channelParentId) - , ("thread_metadata", toJSON <$> channelThreadMetadata) - , ("member", toJSON <$> channelThreadMember) - ] ] - toJSON ChannelPublicThread{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> channelThreadName) - , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) - , ("last_message_id", toJSON <$> channelLastMessage) - , ("parent_id", toJSON <$> pure channelParentId) - , ("thread_metadata", toJSON <$> channelThreadMetadata) - , ("member", toJSON <$> channelThreadMember) - ] ] - toJSON ChannelPrivateThread{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("guild_id", toJSON <$> pure channelGuild) - , ("name", toJSON <$> channelThreadName) - , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) - , ("last_message_id", toJSON <$> channelLastMessage) - , ("parent_id", toJSON <$> pure channelParentId) - , ("thread_metadata", toJSON <$> channelThreadMetadata) - , ("member", toJSON <$> channelThreadMember) - ] ] - toJSON ChannelUnknownType{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure channelId) - , ("json", toJSON <$> pure channelJSON) - ] ] + toJSON ChannelText {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> pure channelName) + , ("position" , toJSON <$> pure channelPosition) + , ("rate_limit_per_user" , toJSON <$> pure channelUserRateLimit) + , ("nsfw" , toJSON <$> pure channelNSFW) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("topic" , toJSON <$> pure channelTopic) + , ("last_message_id" , toJSON <$> channelLastMessage) + , ("parent_id" , toJSON <$> pure channelParentId) + ] + ] + toJSON ChannelNews {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> pure channelName) + , ("position" , toJSON <$> pure channelPosition) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("nsfw" , toJSON <$> pure channelNSFW) + , ("topic" , toJSON <$> pure channelTopic) + , ("last_message_id" , toJSON <$> channelLastMessage) + ] + ] + toJSON ChannelStorePage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> pure channelName) + , ("nsfw" , toJSON <$> pure channelNSFW) + , ("position" , toJSON <$> pure channelPosition) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + ] + ] + toJSON ChannelDirectMessage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("recipients" , toJSON <$> pure channelRecipients) + , ("last_message_id", toJSON <$> channelLastMessage) + ] + ] + toJSON ChannelVoice {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> pure channelName) + , ("position" , toJSON <$> pure channelPosition) + , ("nsfw" , toJSON <$> pure channelNSFW) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("bitrate" , toJSON <$> pure channelBitRate) + , ("user_limit" , toJSON <$> pure channelUserLimit) + ] + ] + toJSON ChannelGroupDM {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("recipients" , toJSON <$> pure channelRecipients) + , ("last_message_id", toJSON <$> channelLastMessage) + ] + ] + toJSON ChannelGuildCategory {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("name" , toJSON <$> pure channelName) + , ("guild_id", toJSON <$> pure channelGuild) + ] + ] + toJSON ChannelStage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("channel_id", toJSON <$> pure channelStageId) + , ("topic" , toJSON <$> pure channelStageTopic) + ] + ] + toJSON ChannelNewsThread {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> channelThreadName) + , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) + , ("last_message_id" , toJSON <$> channelLastMessage) + , ("parent_id" , toJSON <$> pure channelParentId) + , ("thread_metadata" , toJSON <$> channelThreadMetadata) + , ("member" , toJSON <$> channelThreadMember) + ] + ] + toJSON ChannelPublicThread {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> channelThreadName) + , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) + , ("last_message_id" , toJSON <$> channelLastMessage) + , ("parent_id" , toJSON <$> pure channelParentId) + , ("thread_metadata" , toJSON <$> channelThreadMetadata) + , ("member" , toJSON <$> channelThreadMember) + ] + ] + toJSON ChannelPrivateThread {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure channelId) + , ("guild_id" , toJSON <$> pure channelGuild) + , ("name" , toJSON <$> channelThreadName) + , ("rate_limit_per_user", toJSON <$> channelUserRateLimitThread) + , ("last_message_id" , toJSON <$> channelLastMessage) + , ("parent_id" , toJSON <$> pure channelParentId) + , ("thread_metadata" , toJSON <$> channelThreadMetadata) + , ("member" , toJSON <$> channelThreadMember) + ] + ] + toJSON ChannelUnknownType {..} = object + [ (name, value) + | (name, Just value) <- + [("id", toJSON <$> pure channelId), ("json", toJSON <$> pure channelJSON)] + ] -- | If the channel is part of a guild (has a guild id field) channelIsInGuild :: Channel -> Bool channelIsInGuild c = case c of - ChannelGuildCategory{} -> True - ChannelText{} -> True - ChannelVoice{} -> True - ChannelNews{} -> True - ChannelStorePage{} -> True - ChannelNewsThread{} -> True - ChannelPublicThread{} -> True - ChannelPrivateThread{} -> True - _ -> False + ChannelGuildCategory{} -> True + ChannelText{} -> True + ChannelVoice{} -> True + ChannelNews{} -> True + ChannelStorePage{} -> True + ChannelNewsThread{} -> True + ChannelPublicThread{} -> True + ChannelPrivateThread{} -> True + _ -> False -- | Permission overwrites for a channel. data Overwrite = Overwrite @@ -337,212 +478,289 @@ data Overwrite = Overwrite , overwriteType :: Integer -- ^ Either role (0) or member (1) , overwriteAllow :: T.Text -- ^ Allowed permission bit set , overwriteDeny :: T.Text -- ^ Denied permission bit set - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON Overwrite where parseJSON = withObject "Overwrite" $ \o -> - Overwrite <$> o .: "id" - <*> o .: "type" - <*> o .: "allow" - <*> o .: "deny" + Overwrite <$> o .: "id" <*> o .: "type" <*> o .: "allow" <*> o .: "deny" instance ToJSON Overwrite where - toJSON Overwrite{..} = object - [ ("id", toJSON overwriteId) - , ("type", toJSON overwriteType) - , ("allow", toJSON overwriteAllow) - , ("deny", toJSON overwriteDeny) - ] + toJSON Overwrite {..} = object + [ ("id" , toJSON overwriteId) + , ("type" , toJSON overwriteType) + , ("allow", toJSON overwriteAllow) + , ("deny" , toJSON overwriteDeny) + ] -- | Metadata for threads. data ThreadMetadata = ThreadMetadata - { threadMetadataArchived :: Bool -- ^ Is the thread archived? - , threadMetadataAutoArchive :: Integer -- ^ How long after activity should the thread auto archive - , threadMetadataArchiveTime :: UTCTime -- ^ When was the last time the archive status changed? - , threadMetadataLocked :: Bool -- ^ Is the thread locked? (only MANAGE_THREADS users can unarchive) - , threadMetadataInvitable :: Maybe Bool -- ^ Can non-mods add other non-mods? (private threads only) - , threadMetadataCreateTime :: Maybe UTCTime -- ^ When was the thread created? - } deriving (Show, Read, Eq, Ord) + { threadMetadataArchived :: Bool -- ^ Is the thread archived? + , threadMetadataAutoArchive :: Integer -- ^ How long after activity should the thread auto archive + , threadMetadataArchiveTime :: UTCTime -- ^ When was the last time the archive status changed? + , threadMetadataLocked :: Bool -- ^ Is the thread locked? (only MANAGE_THREADS users can unarchive) + , threadMetadataInvitable :: Maybe Bool -- ^ Can non-mods add other non-mods? (private threads only) + , threadMetadataCreateTime :: Maybe UTCTime -- ^ When was the thread created? + } + deriving (Show, Read, Eq, Ord) instance FromJSON ThreadMetadata where parseJSON = withObject "ThreadMetadata" $ \o -> - ThreadMetadata <$> o .: "archived" - <*> o .: "auto_archive_duration" - <*> o .: "archive_timestamp" - <*> o .: "locked" - <*> o .:? "invitable" - <*> o .:? "create_timestamp" + ThreadMetadata + <$> o + .: "archived" + <*> o + .: "auto_archive_duration" + <*> o + .: "archive_timestamp" + <*> o + .: "locked" + <*> o + .:? "invitable" + <*> o + .:? "create_timestamp" instance ToJSON ThreadMetadata where - toJSON ThreadMetadata{..} = object [(name,value) | (name, Just value) <- - [ ("archived", toJSON <$> pure threadMetadataArchived) - , ("auto_archive_duration", toJSON <$> pure threadMetadataAutoArchive) - , ("archive_timestamp", toJSON <$> pure threadMetadataArchiveTime) - , ("locked", toJSON <$> pure threadMetadataLocked) - , ("invitable", toJSON <$> threadMetadataInvitable) - , ("create_timestamp", toJSON <$> pure threadMetadataCreateTime) - ] ] + toJSON ThreadMetadata {..} = object + [ (name, value) + | (name, Just value) <- + [ ("archived" , toJSON <$> pure threadMetadataArchived) + , ("auto_archive_duration", toJSON <$> pure threadMetadataAutoArchive) + , ("archive_timestamp" , toJSON <$> pure threadMetadataArchiveTime) + , ("locked" , toJSON <$> pure threadMetadataLocked) + , ("invitable" , toJSON <$> threadMetadataInvitable) + , ("create_timestamp" , toJSON <$> pure threadMetadataCreateTime) + ] + ] data ThreadMember = ThreadMember - { threadMemberThreadId :: Maybe ChannelId -- ^ id of the thread - , threadMemberUserId :: Maybe UserId -- ^ id of the user - , threadMemberJoinTime :: UTCTime -- ^ time the current user last joined the thread - , threadMemberFlags :: Integer -- ^ user-thread settings - } deriving (Show, Read, Eq, Ord) + { threadMemberThreadId :: Maybe ChannelId -- ^ id of the thread + , threadMemberUserId :: Maybe UserId -- ^ id of the user + , threadMemberJoinTime :: UTCTime -- ^ time the current user last joined the thread + , threadMemberFlags :: Integer -- ^ user-thread settings + } + deriving (Show, Read, Eq, Ord) instance FromJSON ThreadMember where parseJSON = withObject "ThreadMember" $ \o -> - ThreadMember <$> o .:? "id" - <*> o .:? "user_id" - <*> o .: "join_timestamp" - <*> o .: "flags" + ThreadMember + <$> o + .:? "id" + <*> o + .:? "user_id" + <*> o + .: "join_timestamp" + <*> o + .: "flags" instance ToJSON ThreadMember where - toJSON ThreadMember{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> threadMemberThreadId) - , ("user_id", toJSON <$> threadMemberUserId) - , ("join_timestamp", toJSON <$> pure threadMemberJoinTime) - , ("flags", toJSON <$> pure threadMemberFlags) - ] ] - -data ThreadListSyncFields = ThreadListSyncFields - { threadListSyncFieldsGuildId :: GuildId - , threadListSyncFieldsChannelIds :: Maybe [ChannelId] - , threadListSyncFieldsThreads :: [Channel] + toJSON ThreadMember {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> threadMemberThreadId) + , ("user_id" , toJSON <$> threadMemberUserId) + , ("join_timestamp", toJSON <$> pure threadMemberJoinTime) + , ("flags" , toJSON <$> pure threadMemberFlags) + ] + ] + +data ThreadListSyncFields = ThreadListSyncFields + { threadListSyncFieldsGuildId :: GuildId + , threadListSyncFieldsChannelIds :: Maybe [ChannelId] + , threadListSyncFieldsThreads :: [Channel] , threadListSyncFieldsThreadMembers :: [ThreadMember] - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON ThreadListSyncFields where parseJSON = withObject "ThreadListSyncFields" $ \o -> - ThreadListSyncFields <$> o .: "guild_id" - <*> o .:? "channel_ids" - <*> o .: "threads" - <*> o .: "members" - -data ThreadMembersUpdateFields = ThreadMembersUpdateFields - { threadMembersUpdateFieldsThreadId :: ChannelId - , threadMembersUpdateFieldsGuildId :: GuildId - , threadMembersUpdateFieldsMemberCount :: Integer - , threadMembersUpdateFieldsAddedMembers :: Maybe [ThreadMember] + ThreadListSyncFields + <$> o + .: "guild_id" + <*> o + .:? "channel_ids" + <*> o + .: "threads" + <*> o + .: "members" + +data ThreadMembersUpdateFields = ThreadMembersUpdateFields + { threadMembersUpdateFieldsThreadId :: ChannelId + , threadMembersUpdateFieldsGuildId :: GuildId + , threadMembersUpdateFieldsMemberCount :: Integer + , threadMembersUpdateFieldsAddedMembers :: Maybe [ThreadMember] , threadMembersUpdateFieldsRemovedMembers :: Maybe [UserId] - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON ThreadMembersUpdateFields where parseJSON = withObject "ThreadMembersUpdateFields" $ \o -> - ThreadMembersUpdateFields <$> o .: "id" - <*> o .: "guild_id" - <*> o .: "member_count" - <*> o .:? "added_members" - <*> o .:? "removed_member_ids" + ThreadMembersUpdateFields + <$> o + .: "id" + <*> o + .: "guild_id" + <*> o + .: "member_count" + <*> o + .:? "added_members" + <*> o + .:? "removed_member_ids" -- | Represents information about a message in a Discord channel. data Message = Message - { messageId :: MessageId -- ^ The id of the message - , messageChannelId :: ChannelId -- ^ Id of the channel the message + { messageId :: MessageId -- ^ The id of the message + , messageChannelId :: ChannelId -- ^ Id of the channel the message -- was sent in - , messageGuildId :: Maybe GuildId -- ^ The guild the message went to - , messageAuthor :: User -- ^ The 'User' the message was sent + , messageGuildId :: Maybe GuildId -- ^ The guild the message went to + , messageAuthor :: User -- ^ The 'User' the message was sent -- by - , messageMember :: Maybe GuildMember -- ^ A partial guild member object - , messageContent :: Text -- ^ Contents of the message - , messageTimestamp :: UTCTime -- ^ When the message was sent - , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited - , messageTts :: Bool -- ^ Whether this message was a TTS + , messageMember :: Maybe GuildMember -- ^ A partial guild member object + , messageContent :: Text -- ^ Contents of the message + , messageTimestamp :: UTCTime -- ^ When the message was sent + , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited + , messageTts :: Bool -- ^ Whether this message was a TTS -- message - , messageEveryone :: Bool -- ^ Whether this message mentions + , messageEveryone :: Bool -- ^ Whether this message mentions -- everyone - , messageMentions :: [User] -- ^ 'User's specifically mentioned in + , messageMentions :: [User] -- ^ 'User's specifically mentioned in -- the message - , messageMentionRoles :: [RoleId] -- ^ 'Role's specifically mentioned in + , messageMentionRoles :: [RoleId] -- ^ 'Role's specifically mentioned in -- the message - , messageAttachments :: [Attachment] -- ^ Any attached files - , messageEmbeds :: [Embed] -- ^ Any embedded content - , messageReactions :: [MessageReaction] -- ^ Any reactions to message - , messageNonce :: Maybe Nonce -- ^ Used for validating if a message + , messageAttachments :: [Attachment] -- ^ Any attached files + , messageEmbeds :: [Embed] -- ^ Any embedded content + , messageReactions :: [MessageReaction] -- ^ Any reactions to message + , messageNonce :: Maybe Nonce -- ^ Used for validating if a message -- was sent - , messagePinned :: Bool -- ^ Whether this message is pinned - , messageWebhookId :: Maybe WebhookId -- ^ The webhook id of the webhook that made the message - , messageType :: MessageType -- ^ What type of message is this. - , messageActivity :: Maybe MessageActivity -- ^ sent with Rich Presence-related chat embeds - , messageApplicationId :: Maybe ApplicationId -- ^ if the message is a response to an Interaction, this is the id of the interaction's application - , messageReference :: Maybe MessageReference -- ^ Reference IDs of the original message - , messageFlags :: Maybe MessageFlags -- ^ Various message flags - , messageReferencedMessage :: Maybe Message -- ^ The full original message - , messageInteraction :: Maybe MessageInteraction -- ^ sent if message is an interaction response - , messageThread :: Maybe Channel -- ^ the thread that was started from this message, includes thread member object - , messageComponents :: Maybe [ComponentActionRow] -- ^ sent if the message contains components like buttons, action rows, or other interactive components - , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers - } deriving (Show, Read, Eq, Ord) + , messagePinned :: Bool -- ^ Whether this message is pinned + , messageWebhookId :: Maybe WebhookId -- ^ The webhook id of the webhook that made the message + , messageType :: MessageType -- ^ What type of message is this. + , messageActivity :: Maybe MessageActivity -- ^ sent with Rich Presence-related chat embeds + , messageApplicationId :: Maybe ApplicationId -- ^ if the message is a response to an Interaction, this is the id of the interaction's application + , messageReference :: Maybe MessageReference -- ^ Reference IDs of the original message + , messageFlags :: Maybe MessageFlags -- ^ Various message flags + , messageReferencedMessage :: Maybe Message -- ^ The full original message + , messageInteraction :: Maybe MessageInteraction -- ^ sent if message is an interaction response + , messageThread :: Maybe Channel -- ^ the thread that was started from this message, includes thread member object + , messageComponents :: Maybe [ComponentActionRow] -- ^ sent if the message contains components like buttons, action rows, or other interactive components + , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers + } + deriving (Show, Read, Eq, Ord) instance FromJSON Message where parseJSON = withObject "Message" $ \o -> - Message <$> o .: "id" - <*> o .: "channel_id" - <*> o .:? "guild_id" .!= Nothing - <*> (do isW <- o .:? "webhook_id" - a <- o .: "author" - case isW :: Maybe WebhookId of - Nothing -> pure a - Just _ -> pure $ a { userIsWebhook = True }) - <*> o .:? "member" - <*> o .:? "content" .!= "" - <*> o .:? "timestamp" .!= epochTime - <*> o .:? "edited_timestamp" - <*> o .:? "tts" .!= False - <*> o .:? "mention_everyone" .!= False - <*> o .:? "mentions" .!= [] - <*> o .:? "mention_roles" .!= [] - <*> o .:? "attachments" .!= [] - <*> o .: "embeds" - <*> o .:? "reactions" .!= [] - <*> o .:? "nonce" - <*> o .:? "pinned" .!= False - <*> o .:? "webhook_id" - <*> o .: "type" - <*> o .:? "activity" + Message + <$> o + .: "id" + <*> o + .: "channel_id" + <*> o + .:? "guild_id" + .!= Nothing + <*> (do + isW <- o .:? "webhook_id" + a <- o .: "author" + case isW :: Maybe WebhookId of + Nothing -> pure a + Just _ -> pure $ a { userIsWebhook = True } + ) + <*> o + .:? "member" + <*> o + .:? "content" + .!= "" + <*> o + .:? "timestamp" + .!= epochTime + <*> o + .:? "edited_timestamp" + <*> o + .:? "tts" + .!= False + <*> o + .:? "mention_everyone" + .!= False + <*> o + .:? "mentions" + .!= [] + <*> o + .:? "mention_roles" + .!= [] + <*> o + .:? "attachments" + .!= [] + <*> o + .: "embeds" + <*> o + .:? "reactions" + .!= [] + <*> o + .:? "nonce" + <*> o + .:? "pinned" + .!= False + <*> o + .:? "webhook_id" + <*> o + .: "type" + <*> o + .:? "activity" -- <*> o .:? "application" - <*> o .:? "application_id" - <*> o .:? "message_reference" .!= Nothing - <*> o .:? "flags" - <*> o .:? "referenced_message" .!= Nothing - <*> o .:? "interaction" - <*> o .:? "thread" - <*> o .:? "components" - <*> o .:? "sticker_items" + <*> o + .:? "application_id" + <*> o + .:? "message_reference" + .!= Nothing + <*> o + .:? "flags" + <*> o + .:? "referenced_message" + .!= Nothing + <*> o + .:? "interaction" + <*> o + .:? "thread" + <*> o + .:? "components" + <*> o + .:? "sticker_items" instance ToJSON Message where - toJSON Message {..} = object [(name, value) | (name, Just value) <- - [ ("id", toJSON <$> pure messageId) - , ("channel_id", toJSON <$> pure messageChannelId) - , ("guild_id", toJSON <$> messageGuildId) - , ("author", toJSON <$> pure messageAuthor) - , ("member", toJSON <$> messageMember) - , ("content", toJSON <$> pure messageContent) - , ("timestamp", toJSON <$> pure messageTimestamp) - , ("edited_timestamp", toJSON <$> messageEdited) - , ("tts", toJSON <$> pure messageTts) - , ("mention_everyone", toJSON <$> pure messageEveryone) - , ("mentions", toJSON <$> pure messageMentions) - , ("mention_roles", toJSON <$> pure messageMentionRoles) - , ("attachments", toJSON <$> pure messageAttachments) - , ("embeds", toJSON <$> pure messageEmbeds) - , ("reactions", toJSON <$> pure messageReactions) - , ("nonce", toJSON <$> messageNonce) - , ("pinned", toJSON <$> pure messagePinned) - , ("webhook_id", toJSON <$> messageWebhookId) - , ("type", toJSON <$> pure messageType) - , ("activity", toJSON <$> messageActivity) - -- , ("application", toJSON <$> messageApplication) - , ("application_id", toJSON <$> messageApplicationId) - , ("message_reference", toJSON <$> messageReference) - , ("flags", toJSON <$> messageFlags) - , ("referenced_message", toJSON <$> messageReferencedMessage) - , ("interaction", toJSON <$> messageInteraction) - , ("thread", toJSON <$> messageThread) - , ("components", toJSON <$> messageComponents) - , ("sticker_items", toJSON <$> messageStickerItems) - ] ] + toJSON Message {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure messageId) + , ("channel_id" , toJSON <$> pure messageChannelId) + , ("guild_id" , toJSON <$> messageGuildId) + , ("author" , toJSON <$> pure messageAuthor) + , ("member" , toJSON <$> messageMember) + , ("content" , toJSON <$> pure messageContent) + , ("timestamp" , toJSON <$> pure messageTimestamp) + , ("edited_timestamp" , toJSON <$> messageEdited) + , ("tts" , toJSON <$> pure messageTts) + , ("mention_everyone" , toJSON <$> pure messageEveryone) + , ("mentions" , toJSON <$> pure messageMentions) + , ("mention_roles" , toJSON <$> pure messageMentionRoles) + , ("attachments" , toJSON <$> pure messageAttachments) + , ("embeds" , toJSON <$> pure messageEmbeds) + , ("reactions" , toJSON <$> pure messageReactions) + , ("nonce" , toJSON <$> messageNonce) + , ("pinned" , toJSON <$> pure messagePinned) + , ("webhook_id" , toJSON <$> messageWebhookId) + , ("type" , toJSON <$> pure messageType) + , ("activity" , toJSON <$> messageActivity) +-- , ("application", toJSON <$> messageApplication) + , ("application_id" , toJSON <$> messageApplicationId) + , ("message_reference" , toJSON <$> messageReference) + , ("flags" , toJSON <$> messageFlags) + , ("referenced_message", toJSON <$> messageReferencedMessage) + , ("interaction" , toJSON <$> messageInteraction) + , ("thread" , toJSON <$> messageThread) + , ("components" , toJSON <$> messageComponents) + , ("sticker_items" , toJSON <$> messageStickerItems) + ] + ] -- | Data constructor for a part of MessageDetailedOpts. data AllowedMentions = AllowedMentions @@ -552,7 +770,8 @@ data AllowedMentions = AllowedMentions , mentionUserIds :: [UserId] , mentionRoleIds :: [RoleId] , mentionRepliedUser :: Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance Default AllowedMentions where def = AllowedMentions { mentionEveryone = False @@ -564,35 +783,44 @@ instance Default AllowedMentions where } instance ToJSON AllowedMentions where - toJSON AllowedMentions{..} = object [ - ("parse" .= [name :: T.Text | (name, True) <- - [ ("everyone", mentionEveryone), - ("users", mentionUsers && mentionUserIds == []), - ("roles", mentionRoles && mentionRoleIds == []) ] ]), + toJSON AllowedMentions {..} = object + [ ( "parse" + .= [ name :: T.Text + | (name, True) <- + [ ("everyone", mentionEveryone) + , ("users" , mentionUsers && mentionUserIds == []) + , ("roles" , mentionRoles && mentionRoleIds == []) + ] + ] + ) + , -- https://discord.com/developers/docs/resources/channel#allowed-mentions-object -- parse.users and users list cannot both be active, prioritize id list - ("roles" .= mentionRoleIds), - ("users" .= mentionUserIds), - ("replied_user" .= mentionRepliedUser) ] + ("roles" .= mentionRoleIds) + , ("users" .= mentionUserIds) + , ("replied_user" .= mentionRepliedUser) + ] data MessageReaction = MessageReaction - { messageReactionCount :: Int + { messageReactionCount :: Int , messageReactionMeIncluded :: Bool - , messageReactionEmoji :: Emoji - } deriving (Show, Read, Eq, Ord) + , messageReactionEmoji :: Emoji + } + deriving (Show, Read, Eq, Ord) instance FromJSON MessageReaction where - parseJSON = withObject "MessageReaction" $ \o -> - MessageReaction <$> o .: "count" - <*> o .: "me" - <*> o .: "emoji" + parseJSON = withObject "MessageReaction" + $ \o -> MessageReaction <$> o .: "count" <*> o .: "me" <*> o .: "emoji" instance ToJSON MessageReaction where - toJSON MessageReaction{..} = object [(name, value) | (name, Just value) <- + toJSON MessageReaction {..} = object + [ (name, value) + | (name, Just value) <- [ ("count", toJSON <$> pure messageReactionCount) - , ("me", toJSON <$> pure messageReactionMeIncluded) + , ("me" , toJSON <$> pure messageReactionMeIncluded) , ("emoji", toJSON <$> pure messageReactionEmoji) - ]] + ] + ] -- | Represents an attached to a message file. data Attachment = Attachment @@ -603,28 +831,40 @@ data Attachment = Attachment , attachmentProxy :: T.Text -- ^ Proxied url of file , attachmentHeight :: Maybe Integer -- ^ Height of file (if image) , attachmentWidth :: Maybe Integer -- ^ Width of file (if image) - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON Attachment where parseJSON = withObject "Attachment" $ \o -> - Attachment <$> o .: "id" - <*> o .: "filename" - <*> o .: "size" - <*> o .: "url" - <*> o .: "proxy_url" - <*> o .:? "height" - <*> o .:? "width" + Attachment + <$> o + .: "id" + <*> o + .: "filename" + <*> o + .: "size" + <*> o + .: "url" + <*> o + .: "proxy_url" + <*> o + .:? "height" + <*> o + .:? "width" instance ToJSON Attachment where - toJSON Attachment {..} = object [(name, value) | (name, Just value) <- - [ ("id", toJSON <$> pure attachmentId) - , ("filename", toJSON <$> pure attachmentFilename) - , ("size", toJSON <$> pure attachmentSize) - , ("url", toJSON <$> pure attachmentUrl) + toJSON Attachment {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure attachmentId) + , ("filename" , toJSON <$> pure attachmentFilename) + , ("size" , toJSON <$> pure attachmentSize) + , ("url" , toJSON <$> pure attachmentUrl) , ("proxy_url", toJSON <$> pure attachmentProxy) - , ("height", toJSON <$> attachmentHeight) - , ("width", toJSON <$> attachmentWidth) - ] ] + , ("height" , toJSON <$> attachmentHeight) + , ("width" , toJSON <$> attachmentWidth) + ] + ] newtype Nonce = Nonce T.Text deriving (Show, Read, Eq, Ord) @@ -632,7 +872,7 @@ newtype Nonce = Nonce T.Text instance FromJSON Nonce where parseJSON (String nonce) = pure $ Nonce nonce parseJSON (Number nonce) = pure . Nonce . T.pack . show $ nonce - parseJSON _ = empty + parseJSON _ = empty instance ToJSON Nonce where toJSON (Nonce t) = String t @@ -640,26 +880,36 @@ instance ToJSON Nonce where -- | Represents a Message Reference data MessageReference = MessageReference - { referenceMessageId :: Maybe MessageId -- ^ id of the originating message - , referenceChannelId :: Maybe ChannelId -- ^ id of the originating message's channel - , referenceGuildId :: Maybe GuildId -- ^ id of the originating message's guild - , failIfNotExists :: Bool -- ^ Whether to not send if reference not exist - } deriving (Show, Read, Eq, Ord) + { referenceMessageId :: Maybe MessageId -- ^ id of the originating message + , referenceChannelId :: Maybe ChannelId -- ^ id of the originating message's channel + , referenceGuildId :: Maybe GuildId -- ^ id of the originating message's guild + , failIfNotExists :: Bool -- ^ Whether to not send if reference not exist + } + deriving (Show, Read, Eq, Ord) instance FromJSON MessageReference where parseJSON = withObject "MessageReference" $ \o -> - MessageReference <$> o .:? "message_id" - <*> o .:? "channel_id" - <*> o .:? "guild_id" - <*> o .:? "fail_if_not_exists" .!= True + MessageReference + <$> o + .:? "message_id" + <*> o + .:? "channel_id" + <*> o + .:? "guild_id" + <*> o + .:? "fail_if_not_exists" + .!= True instance ToJSON MessageReference where - toJSON MessageReference{..} = object [(name,value) | (name, Just value) <- - [ ("message_id", toJSON <$> pure referenceMessageId) - , ("channel_id", toJSON <$> pure referenceChannelId) - , ("guild_id", toJSON <$> pure referenceGuildId) - , ("fail_if_not_exists", toJSON <$> pure failIfNotExists) - ] ] + toJSON MessageReference {..} = object + [ (name, value) + | (name, Just value) <- + [ ("message_id" , toJSON <$> pure referenceMessageId) + , ("channel_id" , toJSON <$> pure referenceChannelId) + , ("guild_id" , toJSON <$> pure referenceGuildId) + , ("fail_if_not_exists", toJSON <$> pure failIfNotExists) + ] + ] instance Default MessageReference where def = MessageReference { referenceMessageId = Nothing @@ -697,29 +947,29 @@ data MessageType instance InternalDiscordEnum MessageType where discordTypeStartValue = MessageTypeDefault - fromDiscordType MessageTypeDefault = 0 - fromDiscordType MessageTypeRecipientAdd = 1 - fromDiscordType MessageTypeRecipientRemove = 2 - fromDiscordType MessageTypeCall = 3 - fromDiscordType MessageTypeChannelNameChange = 4 - fromDiscordType MessageTypeChannelIconChange = 5 - fromDiscordType MessageTypeChannelPinnedMessage = 6 - fromDiscordType MessageTypeGuildMemberJoin = 7 - fromDiscordType MessageTypeUserPremiumGuildSubscription = 8 + fromDiscordType MessageTypeDefault = 0 + fromDiscordType MessageTypeRecipientAdd = 1 + fromDiscordType MessageTypeRecipientRemove = 2 + fromDiscordType MessageTypeCall = 3 + fromDiscordType MessageTypeChannelNameChange = 4 + fromDiscordType MessageTypeChannelIconChange = 5 + fromDiscordType MessageTypeChannelPinnedMessage = 6 + fromDiscordType MessageTypeGuildMemberJoin = 7 + fromDiscordType MessageTypeUserPremiumGuildSubscription = 8 fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier1 = 9 fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier2 = 10 fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier3 = 11 - fromDiscordType MessageTypeChannelFollowAdd = 12 - fromDiscordType MessageTypeGuildDiscoveryDisqualified = 14 - fromDiscordType MessageTypeGuildDiscoveryRequalified = 15 + fromDiscordType MessageTypeChannelFollowAdd = 12 + fromDiscordType MessageTypeGuildDiscoveryDisqualified = 14 + fromDiscordType MessageTypeGuildDiscoveryRequalified = 15 fromDiscordType MessageTypeGuildDiscoveryGracePeriodInitialWarning = 16 fromDiscordType MessageTypeGuildDiscoveryGracePeriodFinalWarning = 17 - fromDiscordType MessageTypeThreadCreated = 18 - fromDiscordType MessageTypeReply = 19 - fromDiscordType MessageTypeChatInputCommand = 20 - fromDiscordType MessageTypeThreadStarterMessage = 21 - fromDiscordType MessageTypeGuildInviteReminder = 22 - fromDiscordType MessageTypeContextMenuCommand = 23 + fromDiscordType MessageTypeThreadCreated = 18 + fromDiscordType MessageTypeReply = 19 + fromDiscordType MessageTypeChatInputCommand = 20 + fromDiscordType MessageTypeThreadStarterMessage = 21 + fromDiscordType MessageTypeGuildInviteReminder = 22 + fromDiscordType MessageTypeContextMenuCommand = 23 instance ToJSON MessageType where toJSON = toJSON . fromDiscordType @@ -728,21 +978,23 @@ instance FromJSON MessageType where parseJSON = discordTypeParseJSON "MessageType" data MessageActivity = MessageActivity - { messageActivityType :: MessageActivityType + { messageActivityType :: MessageActivityType , messageActivityPartyId :: Maybe T.Text } deriving (Show, Read, Data, Eq, Ord) instance FromJSON MessageActivity where - parseJSON = withObject "MessageActivity" $ \o -> - MessageActivity <$> o .: "type" - <*> o .:? "party_id" + parseJSON = withObject "MessageActivity" + $ \o -> MessageActivity <$> o .: "type" <*> o .:? "party_id" instance ToJSON MessageActivity where - toJSON MessageActivity{..} = object [(name,value) | (name, Just value) <- - [ ("type", toJSON <$> pure messageActivityType) - , ("party_id", toJSON <$> messageActivityPartyId) - ] ] + toJSON MessageActivity {..} = object + [ (name, value) + | (name, Just value) <- + [ ("type" , toJSON <$> pure messageActivityType) + , ("party_id", toJSON <$> messageActivityPartyId) + ] + ] data MessageActivityType = MessageActivityTypeJoin -- ^ Join a Rich Presence event @@ -753,9 +1005,9 @@ data MessageActivityType instance InternalDiscordEnum MessageActivityType where discordTypeStartValue = MessageActivityTypeJoin - fromDiscordType MessageActivityTypeJoin = 1 - fromDiscordType MessageActivityTypeSpectate = 2 - fromDiscordType MessageActivityTypeListen = 3 + fromDiscordType MessageActivityTypeJoin = 1 + fromDiscordType MessageActivityTypeSpectate = 2 + fromDiscordType MessageActivityTypeListen = 3 fromDiscordType MessageActivityTypeJoinRequest = 4 instance ToJSON MessageActivityType where @@ -782,49 +1034,60 @@ newtype MessageFlags = MessageFlags [MessageFlag] instance InternalDiscordEnum MessageFlag where discordTypeStartValue = MessageFlagCrossposted - fromDiscordType MessageFlagCrossposted = 1 `shift` 0 - fromDiscordType MessageFlagIsCrosspost = 1 `shift` 1 - fromDiscordType MessageFlagSupressEmbeds = 1 `shift` 2 - fromDiscordType MessageFlagSourceMessageDeleted = 1 `shift` 3 - fromDiscordType MessageFlagUrgent = 1 `shift` 4 - fromDiscordType MessageFlagHasThread = 1 `shift` 5 - fromDiscordType MessageFlagEphemeral = 1 `shift` 6 - fromDiscordType MessageFlagLoading = 1 `shift` 7 + fromDiscordType MessageFlagCrossposted = 1 `shift` 0 + fromDiscordType MessageFlagIsCrosspost = 1 `shift` 1 + fromDiscordType MessageFlagSupressEmbeds = 1 `shift` 2 + fromDiscordType MessageFlagSourceMessageDeleted = 1 `shift` 3 + fromDiscordType MessageFlagUrgent = 1 `shift` 4 + fromDiscordType MessageFlagHasThread = 1 `shift` 5 + fromDiscordType MessageFlagEphemeral = 1 `shift` 6 + fromDiscordType MessageFlagLoading = 1 `shift` 7 fromDiscordType MessageFlagFailedToMentionRollesInThread = 1 `shift` 8 instance ToJSON MessageFlags where - toJSON (MessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromDiscordType <$> fs) + toJSON (MessageFlags fs) = + Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromDiscordType <$> fs) -- TODO: maybe make this a type class or something - the ability to handle flags automatically would be Very Good. instance FromJSON MessageFlags where parseJSON = withScientific "MessageFlags" $ \s -> - let i = round s - -- TODO check to see that we know about all the flags - -- if i /= (i .&. range) - -- range = sum $ fst <$> (discordTypeTable @MessageFlag) - in return $ MessageFlags (snd <$> filter (\(i',_) -> i .&. i' == i') discordTypeTable) + let i = round s + -- TODO check to see that we know about all the flags + -- if i /= (i .&. range) + -- range = sum $ fst <$> (discordTypeTable @MessageFlag) + in return $ MessageFlags + (snd <$> filter (\(i', _) -> i .&. i' == i') discordTypeTable) -- | This is sent on the message object when the message is a response to an Interaction without an existing message (i.e., any non-component interaction). data MessageInteraction = MessageInteraction - { messageInteractionId :: InteractionId -- ^ Id of the interaction + { messageInteractionId :: InteractionId -- ^ Id of the interaction , messageInteractionType :: Integer -- ^ Type of the interaction (liekly always application command) , messageInteractionName :: T.Text -- ^ Name of the interaction , messageInteractionUser :: User -- ^ User who invoked the interaction - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON MessageInteraction where - toJSON MessageInteraction{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure messageInteractionId) - , ("type", toJSON <$> pure messageInteractionType) - , ("name", toJSON <$> pure messageInteractionName) - , ("user", toJSON <$> pure messageInteractionUser) - ] ] + toJSON MessageInteraction {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure messageInteractionId) + , ("type", toJSON <$> pure messageInteractionType) + , ("name", toJSON <$> pure messageInteractionName) + , ("user", toJSON <$> pure messageInteractionUser) + ] + ] instance FromJSON MessageInteraction where parseJSON = withObject "MessageInteraction" $ \o -> - MessageInteraction <$> o .: "id" - <*> o .: "type" - <*> o .: "name" - <*> o .: "user" + MessageInteraction + <$> o + .: "id" + <*> o + .: "type" + <*> o + .: "name" + <*> o + .: "user" diff --git a/src/Discord/Internal/Types/Color.hs b/src/Discord/Internal/Types/Color.hs index 92250de9..561a4c6e 100644 --- a/src/Discord/Internal/Types/Color.hs +++ b/src/Discord/Internal/Types/Color.hs @@ -4,16 +4,16 @@ module Discord.Internal.Types.Color where -import Text.Read (readMaybe) -import Data.Maybe (fromMaybe) -import Data.Char (toLower) -import Data.Aeson -import Data.Data -import Control.Applicative (Alternative((<|>))) -import Data.Bits (Bits((.&.))) +import Control.Applicative ( Alternative((<|>)) ) +import Data.Aeson +import Data.Bits ( Bits((.&.)) ) +import Data.Char ( toLower ) +import Data.Data +import Data.Maybe ( fromMaybe ) +import Text.Read ( readMaybe ) -import Discord.Internal.Types.Prelude (InternalDiscordEnum(..)) +import Discord.Internal.Types.Prelude ( InternalDiscordEnum(..) ) -- | Color names -- Color is a bit of a mess on discord embeds. @@ -68,97 +68,97 @@ hexToRGB hex = do g <- drop2 h >>= take2 >>= toDec b <- drop2 h >>= drop2 >>= toDec return (r, g, b) - where - take2 (a:b:_) = Just [a, b] - take2 _ = Nothing - drop2 (_ : _ : as) = Just as - drop2 _ = Nothing - toDec :: String -> Maybe Integer - toDec [s, u] = do - a <- charToDec s - b <- charToDec u - return $ a * 16 + b - toDec _ = Nothing - charToDec :: Char -> Maybe Integer - charToDec 'a' = Just 10 - charToDec 'b' = Just 11 - charToDec 'c' = Just 12 - charToDec 'd' = Just 13 - charToDec 'e' = Just 14 - charToDec 'f' = Just 15 - charToDec c = readMaybe [c] + where + take2 (a : b : _) = Just [a, b] + take2 _ = Nothing + drop2 (_ : _ : as) = Just as + drop2 _ = Nothing + toDec :: String -> Maybe Integer + toDec [s, u] = do + a <- charToDec s + b <- charToDec u + return $ a * 16 + b + toDec _ = Nothing + charToDec :: Char -> Maybe Integer + charToDec 'a' = Just 10 + charToDec 'b' = Just 11 + charToDec 'c' = Just 12 + charToDec 'd' = Just 13 + charToDec 'e' = Just 14 + charToDec 'f' = Just 15 + charToDec c = readMaybe [c] -- | @hexToDiscordColor@ converts a potential hex string into a DiscordColor, -- evaluating to Default if it fails. hexToDiscordColor :: String -> DiscordColor hexToDiscordColor hex = - let (r, g, b) = fromMaybe (0, 0, 0) $ hexToRGB hex - in DiscordColorRGB r g b + let (r, g, b) = fromMaybe (0, 0, 0) $ hexToRGB hex in DiscordColorRGB r g b colorToInternal :: DiscordColor -> Integer -- colorToInternal (DiscordColor i) = i -colorToInternal (DiscordColorRGB r g b) = (r * 256 + g) * 256 + b -colorToInternal DiscordColorDefault = 0 -colorToInternal DiscordColorAqua = 1752220 -colorToInternal DiscordColorDarkAqua = 1146986 -colorToInternal DiscordColorGreen = 3066993 -colorToInternal DiscordColorDarkGreen = 2067276 -colorToInternal DiscordColorBlue = 3447003 -colorToInternal DiscordColorDarkBlue = 2123412 -colorToInternal DiscordColorPurple = 10181046 -colorToInternal DiscordColorDarkPurple = 7419530 -colorToInternal DiscordColorLuminousVividPink = 15277667 -colorToInternal DiscordColorDarkVividPink = 11342935 -colorToInternal DiscordColorGold = 15844367 -colorToInternal DiscordColorDarkGold = 12745742 -colorToInternal DiscordColorOrange = 15105570 -colorToInternal DiscordColorDarkOrange = 11027200 -colorToInternal DiscordColorRed = 15158332 -colorToInternal DiscordColorDarkRed = 10038562 -colorToInternal DiscordColorGray = 9807270 -colorToInternal DiscordColorDarkGray = 9936031 -colorToInternal DiscordColorDarkerGray = 8359053 -colorToInternal DiscordColorLightGray = 12370112 -colorToInternal DiscordColorNavy = 3426654 -colorToInternal DiscordColorDarkNavy = 2899536 -colorToInternal DiscordColorYellow = 16776960 -colorToInternal DiscordColorDiscordWhite = 16777215 -colorToInternal DiscordColorDiscordBlurple = 5793266 -colorToInternal DiscordColorDiscordGrayple = 10070709 +colorToInternal (DiscordColorRGB r g b) = (r * 256 + g) * 256 + b +colorToInternal DiscordColorDefault = 0 +colorToInternal DiscordColorAqua = 1752220 +colorToInternal DiscordColorDarkAqua = 1146986 +colorToInternal DiscordColorGreen = 3066993 +colorToInternal DiscordColorDarkGreen = 2067276 +colorToInternal DiscordColorBlue = 3447003 +colorToInternal DiscordColorDarkBlue = 2123412 +colorToInternal DiscordColorPurple = 10181046 +colorToInternal DiscordColorDarkPurple = 7419530 +colorToInternal DiscordColorLuminousVividPink = 15277667 +colorToInternal DiscordColorDarkVividPink = 11342935 +colorToInternal DiscordColorGold = 15844367 +colorToInternal DiscordColorDarkGold = 12745742 +colorToInternal DiscordColorOrange = 15105570 +colorToInternal DiscordColorDarkOrange = 11027200 +colorToInternal DiscordColorRed = 15158332 +colorToInternal DiscordColorDarkRed = 10038562 +colorToInternal DiscordColorGray = 9807270 +colorToInternal DiscordColorDarkGray = 9936031 +colorToInternal DiscordColorDarkerGray = 8359053 +colorToInternal DiscordColorLightGray = 12370112 +colorToInternal DiscordColorNavy = 3426654 +colorToInternal DiscordColorDarkNavy = 2899536 +colorToInternal DiscordColorYellow = 16776960 +colorToInternal DiscordColorDiscordWhite = 16777215 +colorToInternal DiscordColorDiscordBlurple = 5793266 +colorToInternal DiscordColorDiscordGrayple = 10070709 colorToInternal DiscordColorDiscordDarkButNotBlack = 2895667 -colorToInternal DiscordColorDiscordNotQuiteBlack = 2303786 -colorToInternal DiscordColorDiscordGreen = 5763719 -colorToInternal DiscordColorDiscordYellow = 16705372 -colorToInternal DiscordColorDiscordFuschia = 15418782 -colorToInternal DiscordColorDiscordRed = 15548997 -colorToInternal DiscordColorDiscordBlack = 16777215 +colorToInternal DiscordColorDiscordNotQuiteBlack = 2303786 +colorToInternal DiscordColorDiscordGreen = 5763719 +colorToInternal DiscordColorDiscordYellow = 16705372 +colorToInternal DiscordColorDiscordFuschia = 15418782 +colorToInternal DiscordColorDiscordRed = 15548997 +colorToInternal DiscordColorDiscordBlack = 16777215 convertToRGB :: Integer -> DiscordColor -convertToRGB i = DiscordColorRGB (div i (256 * 256) .&. 255) (div i 256 .&. 255) (i .&. 255) +convertToRGB i = + DiscordColorRGB (div i (256 * 256) .&. 255) (div i 256 .&. 255) (i .&. 255) instance InternalDiscordEnum DiscordColor where discordTypeStartValue = DiscordColorDefault - fromDiscordType = fromIntegral . colorToInternal - discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) - where - makeTable :: Data b => b -> [b] - makeTable t = map (fromConstrB (fromConstr (toConstr (0 :: Int)))) (dataTypeConstrs $ dataTypeOf t) + fromDiscordType = fromIntegral . colorToInternal + discordTypeTable = map (\d -> (fromDiscordType d, d)) + (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map (fromConstrB (fromConstr (toConstr (0 :: Int)))) + (dataTypeConstrs $ dataTypeOf t) instance ToJSON DiscordColor where toJSON = toJSON . fromDiscordType instance FromJSON DiscordColor where - parseJSON = - withScientific - "DiscordColor" - ( \v -> - discordTypeParseJSON "DiscordColor" (Number v) - <|> ( case maybeInt v >>= Just . convertToRGB of - Nothing -> fail $ "could not parse discord color: " ++ show v - Just d -> return d - ) - ) - where - maybeInt i - | fromIntegral (round i) == i = Just $ round i - | otherwise = Nothing + parseJSON = withScientific + "DiscordColor" + (\v -> + discordTypeParseJSON "DiscordColor" (Number v) + <|> (case maybeInt v >>= Just . convertToRGB of + Nothing -> fail $ "could not parse discord color: " ++ show v + Just d -> return d + ) + ) + where + maybeInt i | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing diff --git a/src/Discord/Internal/Types/Components.hs b/src/Discord/Internal/Types/Components.hs index 429645bb..dcbc09e6 100644 --- a/src/Discord/Internal/Types/Components.hs +++ b/src/Discord/Internal/Types/Components.hs @@ -7,59 +7,58 @@ {-# LANGUAGE RecordWildCards #-} module Discord.Internal.Types.Components - ( ComponentActionRow (..), - ComponentButton (..), - ButtonStyle (..), - mkButton, - ComponentSelectMenu (..), - mkSelectMenu, - SelectOption (..), - mkSelectOption, - ComponentTextInput (..), - mkComponentTextInput, - ) -where + ( ComponentActionRow(..) + , ComponentButton(..) + , ButtonStyle(..) + , mkButton + , ComponentSelectMenu(..) + , mkSelectMenu + , SelectOption(..) + , mkSelectOption + , ComponentTextInput(..) + , mkComponentTextInput + ) where -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Foldable (Foldable (toList)) -import Data.Scientific (Scientific) -import qualified Data.Text as T -import Discord.Internal.Types.Emoji (Emoji) -import Discord.Internal.Types.Prelude (toMaybeJSON) +import Data.Aeson +import Data.Aeson.Types ( Parser ) +import Data.Foldable ( Foldable(toList) ) +import Data.Scientific ( Scientific ) +import qualified Data.Text as T +import Discord.Internal.Types.Emoji ( Emoji ) +import Discord.Internal.Types.Prelude ( toMaybeJSON ) data ComponentActionRow = ComponentActionRowButton [ComponentButton] | ComponentActionRowSelectMenu ComponentSelectMenu deriving (Show, Read, Eq, Ord) instance FromJSON ComponentActionRow where - parseJSON = - withObject - "ComponentActionRow" - ( \cs -> do - t <- cs .: "type" :: Parser Int - case t of - 1 -> do - a <- cs .: "components" :: Parser Array - let a' = toList a - case a' of - [] -> return $ ComponentActionRowButton [] - (c : _) -> - withObject - "ComponentActionRow item" - ( \v -> do - t' <- v .: "type" :: Parser Int - case t' of - 2 -> ComponentActionRowButton <$> mapM parseJSON a' - 3 -> ComponentActionRowSelectMenu <$> parseJSON c - _ -> fail $ "unknown component type: " ++ show t - ) - c - _ -> fail $ "expected action row type (1), got: " ++ show t - ) + parseJSON = withObject + "ComponentActionRow" + (\cs -> do + t <- cs .: "type" :: Parser Int + case t of + 1 -> do + a <- cs .: "components" :: Parser Array + let a' = toList a + case a' of + [] -> return $ ComponentActionRowButton [] + (c : _) -> withObject + "ComponentActionRow item" + (\v -> do + t' <- v .: "type" :: Parser Int + case t' of + 2 -> ComponentActionRowButton <$> mapM parseJSON a' + 3 -> ComponentActionRowSelectMenu <$> parseJSON c + _ -> fail $ "unknown component type: " ++ show t + ) + c + _ -> fail $ "expected action row type (1), got: " ++ show t + ) instance ToJSON ComponentActionRow where - toJSON (ComponentActionRowButton bs) = object [("type", Number 1), ("components", toJSON bs)] - toJSON (ComponentActionRowSelectMenu bs) = object [("type", Number 1), ("components", toJSON [bs])] + toJSON (ComponentActionRowButton bs) = + object [("type", Number 1), ("components", toJSON bs)] + toJSON (ComponentActionRowSelectMenu bs) = + object [("type", Number 1), ("components", toJSON [bs])] -- | Component type for a button, split into URL button and not URL button. -- @@ -92,62 +91,62 @@ data ComponentButton -- | Takes the label and the custom id of the button that is to be generated. mkButton :: T.Text -> T.Text -> ComponentButton -mkButton label customId = ComponentButton customId False ButtonStyleSecondary (Just label) Nothing +mkButton label customId = + ComponentButton customId False ButtonStyleSecondary (Just label) Nothing instance FromJSON ComponentButton where - parseJSON = - withObject - "ComponentButton" - ( \v -> do - t <- v .: "type" :: Parser Int - case t of - 2 -> do - disabled <- v .:? "disabled" .!= False - label <- v .:? "label" - partialEmoji <- v .:? "emoji" - style <- v .: "style" :: Parser Scientific - case style of - 5 -> - ComponentButtonUrl - <$> v .: "url" - <*> return disabled - <*> return label - <*> return partialEmoji - _ -> - ComponentButton - <$> v .: "custom_id" - <*> return disabled - <*> parseJSON (Number style) - <*> return label - <*> return partialEmoji - _ -> fail "expected button type, got a different component" - ) + parseJSON = withObject + "ComponentButton" + (\v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> do + disabled <- v .:? "disabled" .!= False + label <- v .:? "label" + partialEmoji <- v .:? "emoji" + style <- v .: "style" :: Parser Scientific + case style of + 5 -> + ComponentButtonUrl + <$> v + .: "url" + <*> return disabled + <*> return label + <*> return partialEmoji + _ -> + ComponentButton + <$> v + .: "custom_id" + <*> return disabled + <*> parseJSON (Number style) + <*> return label + <*> return partialEmoji + _ -> fail "expected button type, got a different component" + ) instance ToJSON ComponentButton where - toJSON ComponentButtonUrl {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("type", Just $ Number 2), - ("style", Just $ Number 5), - ("label", toJSON <$> componentButtonLabel), - ("disabled", toMaybeJSON componentButtonDisabled), - ("url", toMaybeJSON componentButtonUrl), - ("emoji", toJSON <$> componentButtonEmoji) - ] + toJSON ComponentButtonUrl {..} = object + [ (name, value) + | (name, Just value) <- + [ ("type" , Just $ Number 2) + , ("style" , Just $ Number 5) + , ("label" , toJSON <$> componentButtonLabel) + , ("disabled", toMaybeJSON componentButtonDisabled) + , ("url" , toMaybeJSON componentButtonUrl) + , ("emoji" , toJSON <$> componentButtonEmoji) ] - toJSON ComponentButton {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("type", Just $ Number 2), - ("style", Just $ toJSON componentButtonStyle), - ("label", toJSON <$> componentButtonLabel), - ("disabled", toMaybeJSON componentButtonDisabled), - ("custom_id", toMaybeJSON componentButtonCustomId), - ("emoji", toJSON <$> componentButtonEmoji) - ] + ] + toJSON ComponentButton {..} = object + [ (name, value) + | (name, Just value) <- + [ ("type" , Just $ Number 2) + , ("style" , Just $ toJSON componentButtonStyle) + , ("label" , toJSON <$> componentButtonLabel) + , ("disabled" , toMaybeJSON componentButtonDisabled) + , ("custom_id", toMaybeJSON componentButtonCustomId) + , ("emoji" , toJSON <$> componentButtonEmoji) ] + ] -- | Buttton colors. data ButtonStyle @@ -162,93 +161,106 @@ data ButtonStyle deriving (Show, Read, Eq, Ord) instance FromJSON ButtonStyle where - parseJSON = - withScientific - "ButtonStyle" - ( \case - 1 -> return ButtonStylePrimary - 2 -> return ButtonStyleSecondary - 3 -> return ButtonStyleSuccess - 4 -> return ButtonStyleDanger - _ -> fail "unrecognised non-url button style" - ) + parseJSON = withScientific + "ButtonStyle" + (\case + 1 -> return ButtonStylePrimary + 2 -> return ButtonStyleSecondary + 3 -> return ButtonStyleSuccess + 4 -> return ButtonStyleDanger + _ -> fail "unrecognised non-url button style" + ) instance ToJSON ButtonStyle where - toJSON ButtonStylePrimary = Number 1 + toJSON ButtonStylePrimary = Number 1 toJSON ButtonStyleSecondary = Number 2 - toJSON ButtonStyleSuccess = Number 3 - toJSON ButtonStyleDanger = Number 4 + toJSON ButtonStyleSuccess = Number 3 + toJSON ButtonStyleDanger = Number 4 -- | Component type for a select menus. -- -- Don't directly send select menus - they need to be within an action row. data ComponentSelectMenu = ComponentSelectMenu { -- | Dev identifier - componentSelectMenuCustomId :: T.Text, + componentSelectMenuCustomId :: T.Text + , -- | Whether the select menu is disabled - componentSelectMenuDisabled :: Bool, + componentSelectMenuDisabled :: Bool + , -- | What options are in this select menu (up to 25) - componentSelectMenuOptions :: [SelectOption], + componentSelectMenuOptions :: [SelectOption] + , -- | Placeholder text if nothing is selected - componentSelectMenuPlaceholder :: Maybe T.Text, + componentSelectMenuPlaceholder :: Maybe T.Text + , -- | Minimum number of values to select (def 1, min 0, max 25) - componentSelectMenuMinValues :: Maybe Integer, + componentSelectMenuMinValues :: Maybe Integer + , -- | Maximum number of values to select (def 1, max 25) - componentSelectMenuMaxValues :: Maybe Integer + componentSelectMenuMaxValues :: Maybe Integer } deriving (Show, Read, Eq, Ord) -- | Takes the custom id and the options of the select menu that is to be -- generated. mkSelectMenu :: T.Text -> [SelectOption] -> ComponentSelectMenu -mkSelectMenu customId sos = ComponentSelectMenu customId False sos Nothing Nothing Nothing +mkSelectMenu customId sos = + ComponentSelectMenu customId False sos Nothing Nothing Nothing instance FromJSON ComponentSelectMenu where - parseJSON = - withObject - "ComponentSelectMenu" - ( \v -> - do - t <- v .: "type" :: Parser Int - case t of - 3 -> - ComponentSelectMenu - <$> v .: "custom_id" - <*> v .:? "disabled" .!= False - <*> v .: "options" - <*> v .:? "placeholder" - <*> v .:? "min_values" - <*> v .:? "max_values" - _ -> fail "expected select menu type, got different component" - ) + parseJSON = withObject + "ComponentSelectMenu" + (\v -> do + t <- v .: "type" :: Parser Int + case t of + 3 -> + ComponentSelectMenu + <$> v + .: "custom_id" + <*> v + .:? "disabled" + .!= False + <*> v + .: "options" + <*> v + .:? "placeholder" + <*> v + .:? "min_values" + <*> v + .:? "max_values" + _ -> fail "expected select menu type, got different component" + ) instance ToJSON ComponentSelectMenu where - toJSON ComponentSelectMenu {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("type", Just $ Number 3), - ("custom_id", toMaybeJSON componentSelectMenuCustomId), - ("disabled", toMaybeJSON componentSelectMenuDisabled), - ("options", toMaybeJSON componentSelectMenuOptions), - ("placeholder", toJSON <$> componentSelectMenuPlaceholder), - ("min_values", toJSON <$> componentSelectMenuMinValues), - ("max_values", toJSON <$> componentSelectMenuMaxValues) - ] + toJSON ComponentSelectMenu {..} = object + [ (name, value) + | (name, Just value) <- + [ ("type" , Just $ Number 3) + , ("custom_id" , toMaybeJSON componentSelectMenuCustomId) + , ("disabled" , toMaybeJSON componentSelectMenuDisabled) + , ("options" , toMaybeJSON componentSelectMenuOptions) + , ("placeholder", toJSON <$> componentSelectMenuPlaceholder) + , ("min_values" , toJSON <$> componentSelectMenuMinValues) + , ("max_values" , toJSON <$> componentSelectMenuMaxValues) ] + ] -- | A single option in a select menu. data SelectOption = SelectOption { -- | User facing option name - selectOptionLabel :: T.Text, + selectOptionLabel :: T.Text + , -- | Dev facing option value - selectOptionValue :: T.Text, + selectOptionValue :: T.Text + , -- | additional description - selectOptionDescription :: Maybe T.Text, + selectOptionDescription :: Maybe T.Text + , -- | A partial emoji to show with the object (id, name, animated) - selectOptionEmoji :: Maybe Emoji, + selectOptionEmoji :: Maybe Emoji + , -- | Use this value by default - selectOptionDefault :: Maybe Bool + selectOptionDefault :: Maybe Bool } deriving (Show, Read, Eq, Ord) @@ -258,76 +270,100 @@ mkSelectOption label value = SelectOption label value Nothing Nothing Nothing instance FromJSON SelectOption where parseJSON = withObject "SelectOption" $ \o -> - SelectOption <$> o .: "label" - <*> o .: "value" - <*> o .:? "description" - <*> o .:? "emoji" - <*> o .:? "default" + SelectOption + <$> o + .: "label" + <*> o + .: "value" + <*> o + .:? "description" + <*> o + .:? "emoji" + <*> o + .:? "default" instance ToJSON SelectOption where - toJSON SelectOption {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("label", toMaybeJSON selectOptionLabel), - ("value", toMaybeJSON selectOptionValue), - ("description", toJSON <$> selectOptionDescription), - ("emoji", toJSON <$> selectOptionEmoji), - ("default", toJSON <$> selectOptionDefault) - ] + toJSON SelectOption {..} = object + [ (name, value) + | (name, Just value) <- + [ ("label" , toMaybeJSON selectOptionLabel) + , ("value" , toMaybeJSON selectOptionValue) + , ("description", toJSON <$> selectOptionDescription) + , ("emoji" , toJSON <$> selectOptionEmoji) + , ("default" , toJSON <$> selectOptionDefault) ] + ] data ComponentTextInput = ComponentTextInput { -- | Dev identifier - componentTextInputCustomId :: T.Text, + componentTextInputCustomId :: T.Text + , -- | What style to use (short or paragraph) - componentTextInputIsParagraph :: Bool, + componentTextInputIsParagraph :: Bool + , -- | The label for this component - componentTextInputLabel :: T.Text, + componentTextInputLabel :: T.Text + , -- | The minimum input length for a text input (0-4000) - componentTextInputMinLength :: Maybe Integer, + componentTextInputMinLength :: Maybe Integer + , -- | The maximum input length for a text input (1-4000) - componentTextInputMaxLength :: Maybe Integer, + componentTextInputMaxLength :: Maybe Integer + , -- | Whether this component is required to be filled - componentTextInputRequired :: Bool, + componentTextInputRequired :: Bool + , -- | The prefilled value for this component (max 4000) - componentTextInputValue :: T.Text, + componentTextInputValue :: T.Text + , -- | Placeholder text if empty (max 4000) componentTextInputPlaceholder :: T.Text } deriving (Show, Read, Eq, Ord) instance ToJSON ComponentTextInput where - toJSON ComponentTextInput {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("type", Just $ Number 4), - ("custom_id", toMaybeJSON componentTextInputCustomId), - ("style", toMaybeJSON (1 + fromEnum componentTextInputIsParagraph)), - ("label", toMaybeJSON componentTextInputLabel), - ("min_length", toJSON <$> componentTextInputMinLength), - ("max_length", toJSON <$> componentTextInputMaxLength), - ("required", toMaybeJSON componentTextInputRequired), - ("value", toMaybeJSON componentTextInputValue), - ("placeholder", toMaybeJSON componentTextInputPlaceholder) - ] + toJSON ComponentTextInput {..} = object + [ (name, value) + | (name, Just value) <- + [ ("type" , Just $ Number 4) + , ("custom_id" , toMaybeJSON componentTextInputCustomId) + , ("style", toMaybeJSON (1 + fromEnum componentTextInputIsParagraph)) + , ("label" , toMaybeJSON componentTextInputLabel) + , ("min_length" , toJSON <$> componentTextInputMinLength) + , ("max_length" , toJSON <$> componentTextInputMaxLength) + , ("required" , toMaybeJSON componentTextInputRequired) + , ("value" , toMaybeJSON componentTextInputValue) + , ("placeholder", toMaybeJSON componentTextInputPlaceholder) ] + ] instance FromJSON ComponentTextInput where parseJSON = withObject "ComponentTextInput" $ \o -> do t <- o .: "type" :: Parser Int case t of 4 -> - ComponentTextInput <$> o .: "custom_id" + ComponentTextInput + <$> o + .: "custom_id" <*> fmap (== (2 :: Int)) (o .:? "style" .!= 1) - <*> o .:? "label" .!= "" - <*> o .:? "min_length" - <*> o .:? "max_length" - <*> o .:? "required" .!= False - <*> o .:? "value" .!= "" - <*> o .:? "placeholder" .!= "" + <*> o + .:? "label" + .!= "" + <*> o + .:? "min_length" + <*> o + .:? "max_length" + <*> o + .:? "required" + .!= False + <*> o + .:? "value" + .!= "" + <*> o + .:? "placeholder" + .!= "" _ -> fail "expected text input, found other type of component" mkComponentTextInput :: T.Text -> T.Text -> ComponentTextInput -mkComponentTextInput cid label = ComponentTextInput cid False label Nothing Nothing True "" "" +mkComponentTextInput cid label = + ComponentTextInput cid False label Nothing Nothing True "" "" diff --git a/src/Discord/Internal/Types/Embed.hs b/src/Discord/Internal/Types/Embed.hs index 67009114..89dab329 100644 --- a/src/Discord/Internal/Types/Embed.hs +++ b/src/Discord/Internal/Types/Embed.hs @@ -5,56 +5,66 @@ -- | Data structures pertaining to Discord Embed module Discord.Internal.Types.Embed where -import Data.Aeson -import Data.Time.Clock -import Data.Default (Default, def) -import qualified Data.Text as T -import qualified Data.ByteString as B -import Data.Functor ((<&>)) - -import Network.HTTP.Client.MultipartFormData (PartM, partFileRequestBody) -import Network.HTTP.Client (RequestBody(RequestBodyBS)) - -import Discord.Internal.Types.Color (DiscordColor) +import Data.Aeson +import qualified Data.ByteString as B +import Data.Default ( Default + , def + ) +import Data.Functor ( (<&>) ) +import qualified Data.Text as T +import Data.Time.Clock + +import Network.HTTP.Client ( RequestBody(RequestBodyBS) ) +import Network.HTTP.Client.MultipartFormData + ( PartM + , partFileRequestBody + ) + +import Discord.Internal.Types.Color ( DiscordColor ) createEmbed :: CreateEmbed -> Embed -createEmbed CreateEmbed{..} = - let - emptyMaybe :: T.Text -> Maybe T.Text - emptyMaybe t = if T.null t then Nothing else Just t - - embedImageToUrl :: T.Text -> CreateEmbedImage -> T.Text - embedImageToUrl place cei = case cei of - CreateEmbedImageUrl t -> t - CreateEmbedImageUpload _ -> T.filter (/=' ') $ "attachment://" <> createEmbedTitle <> place <> ".png" - - embedAuthor = EmbedAuthor createEmbedAuthorName - (emptyMaybe createEmbedAuthorUrl) - (embedImageToUrl "author" <$> createEmbedAuthorIcon) - Nothing - embedImage = (embedImageToUrl "image" <$> createEmbedImage) <&> - \image -> EmbedImage image Nothing Nothing Nothing - embedThumbnail = (embedImageToUrl "thumbnail" <$> createEmbedThumbnail) <&> - \thumbnail -> EmbedThumbnail thumbnail Nothing Nothing Nothing - embedFooter = EmbedFooter createEmbedFooterText - (embedImageToUrl "footer" <$> createEmbedFooterIcon) - Nothing - - in Embed { embedAuthor = Just embedAuthor - , embedTitle = emptyMaybe createEmbedTitle - , embedUrl = emptyMaybe createEmbedUrl - , embedThumbnail = embedThumbnail - , embedDescription = emptyMaybe createEmbedDescription - , embedFields = createEmbedFields - , embedImage = embedImage - , embedFooter = Just embedFooter - , embedColor = createEmbedColor - , embedTimestamp = createEmbedTimestamp +createEmbed CreateEmbed {..} = + let emptyMaybe :: T.Text -> Maybe T.Text + emptyMaybe t = if T.null t then Nothing else Just t + + embedImageToUrl :: T.Text -> CreateEmbedImage -> T.Text + embedImageToUrl place cei = case cei of + CreateEmbedImageUrl t -> t + CreateEmbedImageUpload _ -> + T.filter (/= ' ') + $ "attachment://" + <> createEmbedTitle + <> place + <> ".png" + + embedAuthor = EmbedAuthor + createEmbedAuthorName + (emptyMaybe createEmbedAuthorUrl) + (embedImageToUrl "author" <$> createEmbedAuthorIcon) + Nothing + embedImage = (embedImageToUrl "image" <$> createEmbedImage) + <&> \image -> EmbedImage image Nothing Nothing Nothing + embedThumbnail = (embedImageToUrl "thumbnail" <$> createEmbedThumbnail) + <&> \thumbnail -> EmbedThumbnail thumbnail Nothing Nothing Nothing + embedFooter = EmbedFooter + createEmbedFooterText + (embedImageToUrl "footer" <$> createEmbedFooterIcon) + Nothing + in Embed { embedAuthor = Just embedAuthor + , embedTitle = emptyMaybe createEmbedTitle + , embedUrl = emptyMaybe createEmbedUrl + , embedThumbnail = embedThumbnail + , embedDescription = emptyMaybe createEmbedDescription + , embedFields = createEmbedFields + , embedImage = embedImage + , embedFooter = Just embedFooter + , embedColor = createEmbedColor + , embedTimestamp = createEmbedTimestamp -- can't set these - , embedVideo = Nothing - , embedProvider = Nothing - } + , embedVideo = Nothing + , embedProvider = Nothing + } data CreateEmbed = CreateEmbed { createEmbedAuthorName :: T.Text @@ -70,14 +80,27 @@ data CreateEmbed = CreateEmbed , createEmbedFooterIcon :: Maybe CreateEmbedImage , createEmbedColor :: Maybe DiscordColor , createEmbedTimestamp :: Maybe UTCTime - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) data CreateEmbedImage = CreateEmbedImageUrl T.Text | CreateEmbedImageUpload B.ByteString deriving (Show, Read, Eq, Ord) instance Default CreateEmbed where - def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing Nothing Nothing + def = CreateEmbed "" + "" + Nothing + "" + "" + Nothing + "" + [] + Nothing + "" + Nothing + Nothing + Nothing -- | An embed attached to a message. data Embed = Embed @@ -93,190 +116,206 @@ data Embed = Embed , embedTimestamp :: Maybe UTCTime -- ^ The time of the embed content , embedVideo :: Maybe EmbedVideo -- ^ Only present for "video" types , embedProvider :: Maybe EmbedProvider -- ^ Only present for "video" types - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) -- TODO instance ToJSON Embed where - toJSON Embed{..} = object - [ "author" .= embedAuthor - , "title" .= embedTitle - , "url" .= embedUrl - , "description" .= embedDescription - , "thumbnail" .= embedThumbnail - , "fields" .= embedFields - , "image" .= embedImage - , "footer" .= embedFooter - , "color" .= embedColor - , "timestamp" .= embedTimestamp - , "video" .= embedVideo - , "provider" .= embedProvider + toJSON Embed {..} = object + [ "author" .= embedAuthor + , "title" .= embedTitle + , "url" .= embedUrl + , "description" .= embedDescription + , "thumbnail" .= embedThumbnail + , "fields" .= embedFields + , "image" .= embedImage + , "footer" .= embedFooter + , "color" .= embedColor + , "timestamp" .= embedTimestamp + , "video" .= embedVideo + , "provider" .= embedProvider ] instance FromJSON Embed where parseJSON = withObject "embed" $ \o -> - Embed <$> o .:? "author" - <*> o .:? "title" - <*> o .:? "url" - <*> o .:? "thumbnail" - <*> o .:? "description" - <*> o .:? "fields" .!= [] - <*> o .:? "image" - <*> o .:? "footer" - <*> o .:? "color" - <*> o .:? "timestamp" - <*> o .:? "video" - <*> o .:? "provider" + Embed + <$> o + .:? "author" + <*> o + .:? "title" + <*> o + .:? "url" + <*> o + .:? "thumbnail" + <*> o + .:? "description" + <*> o + .:? "fields" + .!= [] + <*> o + .:? "image" + <*> o + .:? "footer" + <*> o + .:? "color" + <*> o + .:? "timestamp" + <*> o + .:? "video" + <*> o + .:? "provider" data EmbedThumbnail = EmbedThumbnail - { embedThumbnailUrl :: T.Text + { embedThumbnailUrl :: T.Text , embedThumbnailProxyUrl :: Maybe T.Text - , embedThumbnailHeight :: Maybe Integer - , embedThumbnailWidth :: Maybe Integer - } deriving (Show, Read, Eq, Ord) + , embedThumbnailHeight :: Maybe Integer + , embedThumbnailWidth :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedThumbnail where - toJSON (EmbedThumbnail a b c d) = object - [ "url" .= a - , "proxy_url" .= b - , "height" .= c - , "width" .= d - ] + toJSON (EmbedThumbnail a b c d) = + object ["url" .= a, "proxy_url" .= b, "height" .= c, "width" .= d] instance FromJSON EmbedThumbnail where parseJSON = withObject "thumbnail" $ \o -> - EmbedThumbnail <$> o .: "url" - <*> o .:? "proxy_url" - <*> o .:? "height" - <*> o .:? "width" + EmbedThumbnail + <$> o + .: "url" + <*> o + .:? "proxy_url" + <*> o + .:? "height" + <*> o + .:? "width" data EmbedVideo = EmbedVideo - { embedVideoUrl :: Maybe T.Text - , embedProxyUrl :: Maybe T.Text + { embedVideoUrl :: Maybe T.Text + , embedProxyUrl :: Maybe T.Text , embedVideoHeight :: Maybe Integer - , embedVideoWidth :: Maybe Integer - } deriving (Show, Read, Eq, Ord) + , embedVideoWidth :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedVideo where - toJSON (EmbedVideo a a' b c) = object - [ "url" .= a - , "height" .= b - , "width" .= c - , "proxy_url" .= a' - ] + toJSON (EmbedVideo a a' b c) = + object ["url" .= a, "height" .= b, "width" .= c, "proxy_url" .= a'] instance FromJSON EmbedVideo where parseJSON = withObject "video" $ \o -> - EmbedVideo <$> o .:? "url" - <*> o .:? "proxy_url" - <*> o .:? "height" - <*> o .:? "width" + EmbedVideo + <$> o + .:? "url" + <*> o + .:? "proxy_url" + <*> o + .:? "height" + <*> o + .:? "width" data EmbedImage = EmbedImage - { embedImageUrl :: T.Text + { embedImageUrl :: T.Text , embedImageProxyUrl :: Maybe T.Text - , embedImageHeight :: Maybe Integer - , embedImageWidth :: Maybe Integer - } deriving (Show, Read, Eq, Ord) + , embedImageHeight :: Maybe Integer + , embedImageWidth :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedImage where - toJSON (EmbedImage a b c d) = object - [ "url" .= a - , "proxy_url" .= b - , "height" .= c - , "width" .= d - ] + toJSON (EmbedImage a b c d) = + object ["url" .= a, "proxy_url" .= b, "height" .= c, "width" .= d] instance FromJSON EmbedImage where parseJSON = withObject "image" $ \o -> - EmbedImage <$> o .: "url" - <*> o .:? "proxy_url" - <*> o .:? "height" - <*> o .:? "width" + EmbedImage + <$> o + .: "url" + <*> o + .:? "proxy_url" + <*> o + .:? "height" + <*> o + .:? "width" data EmbedProvider = EmbedProvider { embedProviderName :: Maybe T.Text - , embedProviderUrl :: Maybe T.Text - } deriving (Show, Read, Eq, Ord) + , embedProviderUrl :: Maybe T.Text + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedProvider where - toJSON (EmbedProvider a b) = object - [ "name" .= a - , "url" .= b - ] + toJSON (EmbedProvider a b) = object ["name" .= a, "url" .= b] instance FromJSON EmbedProvider where - parseJSON = withObject "provider" $ \o -> - EmbedProvider <$> o .:? "name" - <*> o .:? "url" + parseJSON = + withObject "provider" $ \o -> EmbedProvider <$> o .:? "name" <*> o .:? "url" data EmbedAuthor = EmbedAuthor - { embedAuthorName :: T.Text - , embedAuthorUrl :: Maybe T.Text - , embedAuthorIconUrl :: Maybe T.Text + { embedAuthorName :: T.Text + , embedAuthorUrl :: Maybe T.Text + , embedAuthorIconUrl :: Maybe T.Text , embedAuthorProxyIconUrl :: Maybe T.Text - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedAuthor where - toJSON (EmbedAuthor a b c d) = object - [ "name" .= a - , "url" .= b - , "icon_url" .= c - , "proxy_icon_url" .= d - ] + toJSON (EmbedAuthor a b c d) = + object ["name" .= a, "url" .= b, "icon_url" .= c, "proxy_icon_url" .= d] instance FromJSON EmbedAuthor where parseJSON = withObject "author" $ \o -> - EmbedAuthor <$> o .: "name" - <*> o .:? "url" - <*> o .:? "icon_url" - <*> o .:? "proxy_icon_url" + EmbedAuthor + <$> o + .: "name" + <*> o + .:? "url" + <*> o + .:? "icon_url" + <*> o + .:? "proxy_icon_url" data EmbedFooter = EmbedFooter - { embedFooterText :: T.Text - , embedFooterIconUrl :: Maybe T.Text + { embedFooterText :: T.Text + , embedFooterIconUrl :: Maybe T.Text , embedFooterProxyIconUrl :: Maybe T.Text - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedFooter where - toJSON (EmbedFooter a b c) = object - [ "text" .= a - , "icon_url" .= b - , "proxy_icon_url" .= c - ] + toJSON (EmbedFooter a b c) = + object ["text" .= a, "icon_url" .= b, "proxy_icon_url" .= c] instance FromJSON EmbedFooter where parseJSON = withObject "footer" $ \o -> - EmbedFooter <$> o .: "text" - <*> o .:? "icon_url" - <*> o .:? "proxy_icon_url" + EmbedFooter <$> o .: "text" <*> o .:? "icon_url" <*> o .:? "proxy_icon_url" data EmbedField = EmbedField - { embedFieldName :: T.Text - , embedFieldValue :: T.Text + { embedFieldName :: T.Text + , embedFieldValue :: T.Text , embedFieldInline :: Maybe Bool - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance ToJSON EmbedField where - toJSON (EmbedField a b c) = object - [ "name" .= a - , "value" .= b - , "inline" .= c - ] + toJSON (EmbedField a b c) = object ["name" .= a, "value" .= b, "inline" .= c] instance FromJSON EmbedField where - parseJSON = withObject "field" $ \o -> - EmbedField <$> o .: "name" - <*> o .: "value" - <*> o .:? "inline" + parseJSON = withObject "field" + $ \o -> EmbedField <$> o .: "name" <*> o .: "value" <*> o .:? "inline" maybeEmbed :: Maybe CreateEmbed -> [PartM IO] maybeEmbed = - let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) - uploads CreateEmbed{..} = [(T.filter (/=' ') $ createEmbedTitle<>n,c) | (n, Just (CreateEmbedImageUpload c)) <- - [ ("author.png", createEmbedAuthorIcon) - , ("thumbnail.png", createEmbedThumbnail) - , ("image.png", createEmbedImage) - , ("footer.png", createEmbedFooterIcon) ]] - in maybe [] (map mkPart . uploads) + let mkPart (name, content) = + partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed {..} = + [ (T.filter (/= ' ') $ createEmbedTitle <> n, c) + | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png" , createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png" , createEmbedImage) + , ("footer.png" , createEmbedFooterIcon) + ] + ] + in maybe [] (map mkPart . uploads) diff --git a/src/Discord/Internal/Types/Emoji.hs b/src/Discord/Internal/Types/Emoji.hs index 0aecbec1..34c183bf 100644 --- a/src/Discord/Internal/Types/Emoji.hs +++ b/src/Discord/Internal/Types/Emoji.hs @@ -4,25 +4,30 @@ module Discord.Internal.Types.Emoji where -import Data.Aeson -import Data.Data -import Data.Functor ((<&>)) -import Data.Text as T -import Discord.Internal.Types.Prelude -import Discord.Internal.Types.User +import Data.Aeson +import Data.Data +import Data.Functor ( (<&>) ) +import Data.Text as T +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User -- | Represents an emoticon (emoji) data Emoji = Emoji { -- | The emoji id - emojiId :: Maybe EmojiId, + emojiId :: Maybe EmojiId + , -- | The emoji name - emojiName :: T.Text, + emojiName :: T.Text + , -- | Roles the emoji is active for - emojiRoles :: Maybe [RoleId], + emojiRoles :: Maybe [RoleId] + , -- | User that created this emoji - emojiUser :: Maybe User, + emojiUser :: Maybe User + , -- | Whether this emoji is managed - emojiManaged :: Maybe Bool, + emojiManaged :: Maybe Bool + , -- | Whether this emoji is animated emojiAnimated :: Maybe Bool } @@ -34,121 +39,160 @@ mkEmoji t = Emoji Nothing t Nothing Nothing Nothing Nothing instance FromJSON Emoji where parseJSON = withObject "Emoji" $ \o -> - Emoji <$> o .:? "id" - <*> o .: "name" - <*> o .:? "roles" - <*> o .:? "user" - <*> o .:? "managed" - <*> o .:? "animated" + Emoji + <$> o + .:? "id" + <*> o + .: "name" + <*> o + .:? "roles" + <*> o + .:? "user" + <*> o + .:? "managed" + <*> o + .:? "animated" instance ToJSON Emoji where - toJSON Emoji {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("id", toJSON <$> emojiId), - ("name", toMaybeJSON emojiName), - ("roles", toJSON <$> emojiRoles), - ("user", toJSON <$> emojiUser), - ("managed", toJSON <$> emojiManaged), - ("animated", toJSON <$> emojiAnimated) - ] + toJSON Emoji {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> emojiId) + , ("name" , toMaybeJSON emojiName) + , ("roles" , toJSON <$> emojiRoles) + , ("user" , toJSON <$> emojiUser) + , ("managed" , toJSON <$> emojiManaged) + , ("animated", toJSON <$> emojiAnimated) ] + ] -- | Represents a pack of standard stickers. data StickerPack = StickerPack { -- | The id of the sticker pack - stickerPackId :: Snowflake, + stickerPackId :: Snowflake + , -- | The stickers in the pack - stickerPackStickers :: [Sticker], + stickerPackStickers :: [Sticker] + , -- | The name of the sticker pack - stickerPackName :: T.Text, + stickerPackName :: T.Text + , -- | ID of the pack's SKU - stickerPackSKUId :: Snowflake, + stickerPackSKUId :: Snowflake + , -- | If of the sticker which is shown as the pack's icon - stickerPackCoverStickerId :: Maybe StickerId, + stickerPackCoverStickerId :: Maybe StickerId + , -- | The description of the sticker pack - stickerPackDescription :: T.Text, + stickerPackDescription :: T.Text + , -- | Id of the sticker pack's banner image - stickerPackBannerAssetId :: Maybe Snowflake + stickerPackBannerAssetId :: Maybe Snowflake } deriving (Show, Read, Eq, Ord) instance FromJSON StickerPack where parseJSON = withObject "StickerPack" $ \o -> - StickerPack <$> o .: "id" - <*> o .: "stickers" - <*> o .: "name" - <*> o .: "sku_id" - <*> o .:? "cover_sticker_id" - <*> o .: "description" - <*> o .:? "banner_asset_id" + StickerPack + <$> o + .: "id" + <*> o + .: "stickers" + <*> o + .: "name" + <*> o + .: "sku_id" + <*> o + .:? "cover_sticker_id" + <*> o + .: "description" + <*> o + .:? "banner_asset_id" -- | A full sticker object data Sticker = Sticker { -- | The sticker's id. - stickerId :: StickerId, + stickerId :: StickerId + , -- | For standard stickers, the id of the pack. - stickerStickerPackId :: Maybe Snowflake, + stickerStickerPackId :: Maybe Snowflake + , -- | The sticker's name. - stickerName :: T.Text, + stickerName :: T.Text + , -- | The sticker's description. - stickerDescription :: Maybe T.Text, + stickerDescription :: Maybe T.Text + , -- | Autocomplete/suggestion tags for the sticker (max 200 characters total). - stickerTags :: [T.Text], + stickerTags :: [T.Text] + , -- | Whether the sticker is standard or guild type. - stickerIsStandardType :: Bool, + stickerIsStandardType :: Bool + , -- | The sticker's format type. - stickerFormatType :: StickerFormatType, + stickerFormatType :: StickerFormatType + , -- | Whether this guild sticker can be used. - stickerAvailable :: Maybe Bool, + stickerAvailable :: Maybe Bool + , -- | What guild owns this sticker. - stickerGuildId :: Maybe GuildId, + stickerGuildId :: Maybe GuildId + , -- | What user uploaded the guild sticker. - stickerUser :: Maybe User, + stickerUser :: Maybe User + , -- | A standard sticker's sort order in its pack. - stickerSortValue :: Maybe Integer + stickerSortValue :: Maybe Integer } deriving (Show, Read, Eq, Ord) instance FromJSON Sticker where parseJSON = withObject "Sticker" $ \o -> - Sticker <$> o .: "id" - <*> o .:? "pack_id" - <*> o .: "name" - <*> o .:? "description" + Sticker + <$> o + .: "id" + <*> o + .:? "pack_id" + <*> o + .: "name" + <*> o + .:? "description" <*> ((o .: "tags") <&> T.splitOn "\n") <*> ((o .: "type") <&> (== (1 :: Int))) - <*> o .: "format_type" - <*> o .:? "available" - <*> o .:? "guild_id" - <*> o .:? "user" - <*> o .:? "sort_value" + <*> o + .: "format_type" + <*> o + .:? "available" + <*> o + .:? "guild_id" + <*> o + .:? "user" + <*> o + .:? "sort_value" -- | A simplified sticker object. data StickerItem = StickerItem { -- | The sticker's id. - stickerItemId :: StickerId, + stickerItemId :: StickerId + , -- | The sticker's name. - stickerItemName :: T.Text, + stickerItemName :: T.Text + , -- | The sticker's format type. stickerItemFormatType :: StickerFormatType } deriving (Show, Read, Eq, Ord) instance FromJSON StickerItem where - parseJSON = withObject "StickerItem" $ \o -> - StickerItem <$> o .: "id" - <*> o .: "name" - <*> o .: "format_type" + parseJSON = withObject "StickerItem" + $ \o -> StickerItem <$> o .: "id" <*> o .: "name" <*> o .: "format_type" instance ToJSON StickerItem where - toJSON StickerItem {..} = - object - [ ("id", toJSON stickerItemId), - ("name", toJSON stickerItemName), - ("format_type", toJSON stickerItemFormatType) - ] + toJSON StickerItem {..} = object + [ ("id" , toJSON stickerItemId) + , ("name" , toJSON stickerItemName) + , ("format_type", toJSON stickerItemFormatType) + ] data StickerFormatType = StickerFormatTypePNG @@ -158,8 +202,8 @@ data StickerFormatType instance InternalDiscordEnum StickerFormatType where discordTypeStartValue = StickerFormatTypePNG - fromDiscordType StickerFormatTypePNG = 1 - fromDiscordType StickerFormatTypeAPNG = 2 + fromDiscordType StickerFormatTypePNG = 1 + fromDiscordType StickerFormatTypeAPNG = 2 fromDiscordType StickerFormatTypeLOTTIE = 3 instance ToJSON StickerFormatType where diff --git a/src/Discord/Internal/Types/Events.hs b/src/Discord/Internal/Types/Events.hs index d2a578be..3dd58755 100644 --- a/src/Discord/Internal/Types/Events.hs +++ b/src/Discord/Internal/Types/Events.hs @@ -3,22 +3,25 @@ -- | Data structures pertaining to gateway dispatch 'Event's module Discord.Internal.Types.Events where -import Prelude hiding (id) +import Prelude hiding ( id ) -import Data.Time.ISO8601 (parseISO8601) -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time ( UTCTime ) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) +import Data.Time.ISO8601 ( parseISO8601 ) -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Text as T +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T -import Discord.Internal.Types.Prelude -import Discord.Internal.Types.Channel -import Discord.Internal.Types.Guild -import Discord.Internal.Types.User (User, GuildMember) -import Discord.Internal.Types.Interactions (Interaction) -import Discord.Internal.Types.Emoji (Emoji) +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Emoji ( Emoji ) +import Discord.Internal.Types.Guild +import Discord.Internal.Types.Interactions + ( Interaction ) +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User ( GuildMember + , User + ) -- | Represents possible events sent by discord. Detailed information can be found at https://discord.com/developers/docs/topics/gateway. @@ -31,8 +34,8 @@ data Event = | ThreadCreate Channel | ThreadUpdate Channel | ThreadDelete Channel - | ThreadListSync ThreadListSyncFields - | ThreadMembersUpdate ThreadMembersUpdateFields + | ThreadListSync ThreadListSyncFields + | ThreadMembersUpdate ThreadMembersUpdateFields | ChannelPinsUpdate ChannelId (Maybe UTCTime) | GuildCreate Guild | GuildUpdate Guild @@ -74,8 +77,8 @@ data EventInternalParse = | InternalThreadCreate Channel | InternalThreadUpdate Channel | InternalThreadDelete Channel - | InternalThreadListSync ThreadListSyncFields - | InternalThreadMembersUpdate ThreadMembersUpdateFields + | InternalThreadListSync ThreadListSyncFields + | InternalThreadMembersUpdate ThreadMembersUpdateFields | InternalChannelPinsUpdate ChannelId (Maybe UTCTime) | InternalGuildCreate Guild | InternalGuildUpdate Guild @@ -109,12 +112,15 @@ data EventInternalParse = deriving (Show, Eq, Read) data PartialApplication = PartialApplication - { partialApplicationID :: ApplicationId + { partialApplicationID :: ApplicationId , partialApplicationFlags :: Int - } deriving (Show, Eq, Read) + } + deriving (Show, Eq, Read) instance FromJSON PartialApplication where - parseJSON = withObject "PartialApplication" (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") + parseJSON = withObject + "PartialApplication" + (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") data ReactionInfo = ReactionInfo { reactionUserId :: UserId @@ -122,104 +128,145 @@ data ReactionInfo = ReactionInfo , reactionChannelId :: ChannelId , reactionMessageId :: MessageId , reactionEmoji :: Emoji - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON ReactionInfo where parseJSON = withObject "ReactionInfo" $ \o -> - ReactionInfo <$> o .: "user_id" - <*> o .:? "guild_id" - <*> o .: "channel_id" - <*> o .: "message_id" - <*> o .: "emoji" + ReactionInfo + <$> o + .: "user_id" + <*> o + .:? "guild_id" + <*> o + .: "channel_id" + <*> o + .: "message_id" + <*> o + .: "emoji" -data ReactionRemoveInfo = ReactionRemoveInfo +data ReactionRemoveInfo = ReactionRemoveInfo { reactionRemoveChannelId :: ChannelId , reactionRemoveGuildId :: GuildId , reactionRemoveMessageId :: MessageId , reactionRemoveEmoji :: Emoji - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON ReactionRemoveInfo where parseJSON = withObject "ReactionRemoveInfo" $ \o -> - ReactionRemoveInfo <$> o .: "guild_id" - <*> o .: "channel_id" - <*> o .: "message_id" - <*> o .: "emoji" + ReactionRemoveInfo + <$> o + .: "guild_id" + <*> o + .: "channel_id" + <*> o + .: "message_id" + <*> o + .: "emoji" data TypingInfo = TypingInfo { typingUserId :: UserId , typingChannelId :: ChannelId , typingTimestamp :: UTCTime - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON TypingInfo where - parseJSON = withObject "TypingInfo" $ \o -> - do cid <- o .: "channel_id" - uid <- o .: "user_id" - posix <- o .: "timestamp" - let utc = posixSecondsToUTCTime posix - pure (TypingInfo uid cid utc) + parseJSON = withObject "TypingInfo" $ \o -> do + cid <- o .: "channel_id" + uid <- o .: "user_id" + posix <- o .: "timestamp" + let utc = posixSecondsToUTCTime posix + pure (TypingInfo uid cid utc) -- | Convert ToJSON value to FromJSON value reparse :: (ToJSON a, FromJSON b) => a -> Parser b reparse val = case parseEither parseJSON $ toJSON val of - Left r -> fail r - Right b -> pure b + Left r -> fail r + Right b -> pure b eventParse :: T.Text -> Object -> Parser EventInternalParse eventParse t o = case t of - "READY" -> InternalReady <$> o .: "v" - <*> o .: "user" - <*> o .: "private_channels" - <*> o .: "guilds" - <*> o .: "session_id" - <*> o .: "shard" - <*> o .: "application" - "RESUMED" -> InternalResumed <$> o .: "_trace" - "CHANNEL_CREATE" -> InternalChannelCreate <$> reparse o - "CHANNEL_UPDATE" -> InternalChannelUpdate <$> reparse o - "CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o - "THREAD_CREATE" -> InternalThreadCreate <$> reparse o - "THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o - "THREAD_DELETE" -> InternalThreadDelete <$> reparse o - "THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o - "THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o - "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" - stamp <- o .:? "last_pin_timestamp" - let utc = stamp >>= parseISO8601 - pure (InternalChannelPinsUpdate id utc) - "GUILD_CREATE" -> InternalGuildCreate <$> reparse o - "GUILD_UPDATE" -> InternalGuildUpdate <$> reparse o - "GUILD_DELETE" -> InternalGuildDelete <$> reparse o - "GUILD_BAN_ADD" -> InternalGuildBanAdd <$> o .: "guild_id" <*> o .: "user" - "GUILD_BAN_REMOVE" -> InternalGuildBanRemove <$> o .: "guild_id" <*> o .: "user" - "GUILD_EMOJI_UPDATE" -> InternalGuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" - "GUILD_INTEGRATIONS_UPDATE" -> InternalGuildIntegrationsUpdate <$> o .: "guild_id" - "GUILD_MEMBER_ADD" -> InternalGuildMemberAdd <$> o .: "guild_id" <*> reparse o - "GUILD_MEMBER_REMOVE" -> InternalGuildMemberRemove <$> o .: "guild_id" <*> o .: "user" - "GUILD_MEMBER_UPDATE" -> InternalGuildMemberUpdate <$> o .: "guild_id" - <*> o .: "roles" - <*> o .: "user" - <*> o .:? "nick" - "GUILD_MEMBERS_CHUNK" -> InternalGuildMemberChunk <$> o .: "guild_id" <*> o .: "members" - "GUILD_ROLE_CREATE" -> InternalGuildRoleCreate <$> o .: "guild_id" <*> o .: "role" - "GUILD_ROLE_UPDATE" -> InternalGuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" - "GUILD_ROLE_DELETE" -> InternalGuildRoleDelete <$> o .: "guild_id" <*> o .: "role_id" - "MESSAGE_CREATE" -> InternalMessageCreate <$> reparse o - "MESSAGE_UPDATE" -> InternalMessageUpdate <$> o .: "channel_id" <*> o .: "id" - "MESSAGE_DELETE" -> InternalMessageDelete <$> o .: "channel_id" <*> o .: "id" - "MESSAGE_DELETE_BULK" -> InternalMessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" - "MESSAGE_REACTION_ADD" -> InternalMessageReactionAdd <$> reparse o - "MESSAGE_REACTION_REMOVE" -> InternalMessageReactionRemove <$> reparse o - "MESSAGE_REACTION_REMOVE_ALL" -> InternalMessageReactionRemoveAll <$> o .: "channel_id" - <*> o .: "message_id" - "MESSAGE_REACTION_REMOVE_EMOJI" -> InternalMessageReactionRemoveEmoji <$> reparse o - "PRESENCE_UPDATE" -> InternalPresenceUpdate <$> reparse o - "TYPING_START" -> InternalTypingStart <$> reparse o - "USER_UPDATE" -> InternalUserUpdate <$> reparse o - -- "VOICE_STATE_UPDATE" -> InternalVoiceStateUpdate <$> reparse o - -- "VOICE_SERVER_UPDATE" -> InternalVoiceServerUpdate <$> reparse o - "INTERACTION_CREATE" -> InternalInteractionCreate <$> reparse o - _other_event -> InternalUnknownEvent t <$> reparse o + "READY" -> + InternalReady + <$> o + .: "v" + <*> o + .: "user" + <*> o + .: "private_channels" + <*> o + .: "guilds" + <*> o + .: "session_id" + <*> o + .: "shard" + <*> o + .: "application" + "RESUMED" -> InternalResumed <$> o .: "_trace" + "CHANNEL_CREATE" -> InternalChannelCreate <$> reparse o + "CHANNEL_UPDATE" -> InternalChannelUpdate <$> reparse o + "CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o + "THREAD_CREATE" -> InternalThreadCreate <$> reparse o + "THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o + "THREAD_DELETE" -> InternalThreadDelete <$> reparse o + "THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o + "THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o + "CHANNEL_PINS_UPDATE" -> do + id <- o .: "channel_id" + stamp <- o .:? "last_pin_timestamp" + let utc = stamp >>= parseISO8601 + pure (InternalChannelPinsUpdate id utc) + "GUILD_CREATE" -> InternalGuildCreate <$> reparse o + "GUILD_UPDATE" -> InternalGuildUpdate <$> reparse o + "GUILD_DELETE" -> InternalGuildDelete <$> reparse o + "GUILD_BAN_ADD" -> InternalGuildBanAdd <$> o .: "guild_id" <*> o .: "user" + "GUILD_BAN_REMOVE" -> + InternalGuildBanRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_EMOJI_UPDATE" -> + InternalGuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" + "GUILD_INTEGRATIONS_UPDATE" -> + InternalGuildIntegrationsUpdate <$> o .: "guild_id" + "GUILD_MEMBER_ADD" -> + InternalGuildMemberAdd <$> o .: "guild_id" <*> reparse o + "GUILD_MEMBER_REMOVE" -> + InternalGuildMemberRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_MEMBER_UPDATE" -> + InternalGuildMemberUpdate + <$> o + .: "guild_id" + <*> o + .: "roles" + <*> o + .: "user" + <*> o + .:? "nick" + "GUILD_MEMBERS_CHUNK" -> + InternalGuildMemberChunk <$> o .: "guild_id" <*> o .: "members" + "GUILD_ROLE_CREATE" -> + InternalGuildRoleCreate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_UPDATE" -> + InternalGuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_DELETE" -> + InternalGuildRoleDelete <$> o .: "guild_id" <*> o .: "role_id" + "MESSAGE_CREATE" -> InternalMessageCreate <$> reparse o + "MESSAGE_UPDATE" -> InternalMessageUpdate <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE" -> InternalMessageDelete <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE_BULK" -> + InternalMessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" + "MESSAGE_REACTION_ADD" -> InternalMessageReactionAdd <$> reparse o + "MESSAGE_REACTION_REMOVE" -> InternalMessageReactionRemove <$> reparse o + "MESSAGE_REACTION_REMOVE_ALL" -> + InternalMessageReactionRemoveAll <$> o .: "channel_id" <*> o .: "message_id" + "MESSAGE_REACTION_REMOVE_EMOJI" -> + InternalMessageReactionRemoveEmoji <$> reparse o + "PRESENCE_UPDATE" -> InternalPresenceUpdate <$> reparse o + "TYPING_START" -> InternalTypingStart <$> reparse o + "USER_UPDATE" -> InternalUserUpdate <$> reparse o +-- "VOICE_STATE_UPDATE" -> InternalVoiceStateUpdate <$> reparse o +-- "VOICE_SERVER_UPDATE" -> InternalVoiceServerUpdate <$> reparse o + "INTERACTION_CREATE" -> InternalInteractionCreate <$> reparse o + _other_event -> InternalUnknownEvent t <$> reparse o diff --git a/src/Discord/Internal/Types/Gateway.hs b/src/Discord/Internal/Types/Gateway.hs index fb78a1b2..b5b75822 100644 --- a/src/Discord/Internal/Types/Gateway.hs +++ b/src/Discord/Internal/Types/Gateway.hs @@ -6,21 +6,23 @@ -- Gateway module Discord.Internal.Types.Gateway where -import System.Info - -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Aeson -import Data.Aeson.Types -import Data.Default (Default, def) -import Data.Maybe (fromMaybe) -import Data.Functor -import Text.Read (readMaybe) - -import Discord.Internal.Types.Prelude -import Discord.Internal.Types.Events -import Discord.Internal.Types.Guild (Activity (..)) +import System.Info + +import Data.Aeson +import Data.Aeson.Types +import Data.Default ( Default + , def + ) +import Data.Functor +import Data.Maybe ( fromMaybe ) +import qualified Data.Text as T +import Data.Time ( UTCTime ) +import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) +import Text.Read ( readMaybe ) + +import Discord.Internal.Types.Events +import Discord.Internal.Types.Guild ( Activity(..) ) +import Discord.Internal.Types.Prelude -- | Sent by gateway data GatewayReceivable @@ -43,23 +45,24 @@ data GatewaySendableInternal -- | https://discord.com/developers/docs/topics/gateway#list-of-intents data GatewayIntent = GatewayIntent - { gatewayIntentGuilds :: Bool - , gatewayIntentMembers :: Bool - , gatewayIntentBans :: Bool - , gatewayIntentEmojis :: Bool - , gatewayIntentIntegrations :: Bool - , gatewayIntentWebhooks :: Bool - , gatewayIntentInvites :: Bool - , gatewayIntentVoiceStates :: Bool - , gatewayIntentPrecenses :: Bool - , gatewayIntentMessageChanges :: Bool - , gatewayIntentMessageReactions :: Bool - , gatewayIntentMessageTyping :: Bool - , gatewayIntentDirectMessageChanges :: Bool + { gatewayIntentGuilds :: Bool + , gatewayIntentMembers :: Bool + , gatewayIntentBans :: Bool + , gatewayIntentEmojis :: Bool + , gatewayIntentIntegrations :: Bool + , gatewayIntentWebhooks :: Bool + , gatewayIntentInvites :: Bool + , gatewayIntentVoiceStates :: Bool + , gatewayIntentPrecenses :: Bool + , gatewayIntentMessageChanges :: Bool + , gatewayIntentMessageReactions :: Bool + , gatewayIntentMessageTyping :: Bool + , gatewayIntentDirectMessageChanges :: Bool , gatewayIntentDirectMessageReactions :: Bool - , gatewayIntentDirectMessageTyping :: Bool - , gatewayIntentMessageContent :: Bool - } deriving (Show, Read, Eq, Ord) + , gatewayIntentDirectMessageTyping :: Bool + , gatewayIntentMessageContent :: Bool + } + deriving (Show, Read, Eq, Ord) instance Default GatewayIntent where def = GatewayIntent { gatewayIntentGuilds = True @@ -81,26 +84,28 @@ instance Default GatewayIntent where } compileGatewayIntent :: GatewayIntent -> Int -compileGatewayIntent GatewayIntent{..} = - sum $ [ if on then flag else 0 - | (flag, on) <- [ ( 1, gatewayIntentGuilds) - , (2 ^ 1, gatewayIntentMembers) - , (2 ^ 2, gatewayIntentBans) - , (2 ^ 3, gatewayIntentEmojis) - , (2 ^ 4, gatewayIntentIntegrations) - , (2 ^ 5, gatewayIntentWebhooks) - , (2 ^ 6, gatewayIntentInvites) - , (2 ^ 7, gatewayIntentVoiceStates) - , (2 ^ 8, gatewayIntentPrecenses) - , (2 ^ 9, gatewayIntentMessageChanges) - , (2 ^ 10, gatewayIntentMessageReactions) - , (2 ^ 11, gatewayIntentMessageTyping) - , (2 ^ 12, gatewayIntentDirectMessageChanges) - , (2 ^ 13, gatewayIntentDirectMessageReactions) - , (2 ^ 14, gatewayIntentDirectMessageTyping) - , (2 ^ 15, gatewayIntentMessageContent) - ] - ] +compileGatewayIntent GatewayIntent {..} = + sum + $ [ if on then flag else 0 + | (flag, on) <- + [ (1 , gatewayIntentGuilds) + , (2 ^ 1 , gatewayIntentMembers) + , (2 ^ 2 , gatewayIntentBans) + , (2 ^ 3 , gatewayIntentEmojis) + , (2 ^ 4 , gatewayIntentIntegrations) + , (2 ^ 5 , gatewayIntentWebhooks) + , (2 ^ 6 , gatewayIntentInvites) + , (2 ^ 7 , gatewayIntentVoiceStates) + , (2 ^ 8 , gatewayIntentPrecenses) + , (2 ^ 9 , gatewayIntentMessageChanges) + , (2 ^ 10, gatewayIntentMessageReactions) + , (2 ^ 11, gatewayIntentMessageTyping) + , (2 ^ 12, gatewayIntentDirectMessageChanges) + , (2 ^ 13, gatewayIntentDirectMessageReactions) + , (2 ^ 14, gatewayIntentDirectMessageTyping) + , (2 ^ 15, gatewayIntentMessageContent) + ] + ] -- | Sent to gateway by a user data GatewaySendable @@ -110,25 +115,26 @@ data GatewaySendable deriving (Show, Read, Eq, Ord) data RequestGuildMembersOpts = RequestGuildMembersOpts - { requestGuildMembersOptsGuildId :: GuildId - , requestGuildMembersOptsNamesStartingWith :: T.Text - , requestGuildMembersOptsLimit :: Integer } + { requestGuildMembersOptsGuildId :: GuildId + , requestGuildMembersOptsNamesStartingWith :: T.Text + , requestGuildMembersOptsLimit :: Integer + } deriving (Show, Read, Eq, Ord) data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts - { updateStatusVoiceOptsGuildId :: GuildId - , updateStatusVoiceOptsChannelId :: Maybe ChannelId - , updateStatusVoiceOptsIsMuted :: Bool - , updateStatusVoiceOptsIsDeaf :: Bool - } + { updateStatusVoiceOptsGuildId :: GuildId + , updateStatusVoiceOptsChannelId :: Maybe ChannelId + , updateStatusVoiceOptsIsMuted :: Bool + , updateStatusVoiceOptsIsDeaf :: Bool + } deriving (Show, Read, Eq, Ord) data UpdateStatusOpts = UpdateStatusOpts - { updateStatusOptsSince :: Maybe UTCTime - , updateStatusOptsGame :: Maybe Activity - , updateStatusOptsNewStatus :: UpdateStatusType - , updateStatusOptsAFK :: Bool - } + { updateStatusOptsSince :: Maybe UTCTime + , updateStatusOptsGame :: Maybe Activity + , updateStatusOptsNewStatus :: UpdateStatusType + , updateStatusOptsAFK :: Bool + } deriving (Show, Read, Eq, Ord) data UpdateStatusType = UpdateStatusOnline @@ -140,28 +146,33 @@ data UpdateStatusType = UpdateStatusOnline statusString :: UpdateStatusType -> T.Text statusString s = case s of - UpdateStatusOnline -> "online" - UpdateStatusDoNotDisturb -> "dnd" + UpdateStatusOnline -> "online" + UpdateStatusDoNotDisturb -> "dnd" UpdateStatusAwayFromKeyboard -> "idle" UpdateStatusInvisibleOffline -> "invisible" - UpdateStatusOffline -> "offline" + UpdateStatusOffline -> "offline" instance FromJSON GatewayReceivable where parseJSON = withObject "payload" $ \o -> do op <- o .: "op" :: Parser Int case op of - 0 -> do etype <- o .: "t" - ejson <- o .: "d" - case ejson of - Object hm -> Dispatch <$> eventParse etype hm <*> o .: "s" - _other -> Dispatch (InternalUnknownEvent "Dispatch payload wasn't an object" o) - <$> o .: "s" + 0 -> do + etype <- o .: "t" + ejson <- o .: "d" + case ejson of + Object hm -> Dispatch <$> eventParse etype hm <*> o .: "s" + _other -> + Dispatch + (InternalUnknownEvent "Dispatch payload wasn't an object" o) + <$> o + .: "s" 1 -> HeartbeatRequest . fromMaybe 0 . readMaybe <$> o .: "d" 7 -> pure Reconnect 9 -> InvalidSession <$> o .: "d" - 10 -> do od <- o .: "d" - int <- od .: "heartbeat_interval" - pure (Hello int) + 10 -> do + od <- o .: "d" + int <- od .: "heartbeat_interval" + pure (Hello int) 11 -> pure HeartbeatAck _ -> fail ("Unknown Receivable payload ID:" <> show op) @@ -177,63 +188,59 @@ instance FromJSON GatewayReceivable where -- _ -> fail ("Unknown Sendable payload ID:" <> show op) instance ToJSON GatewaySendableInternal where - toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ] - toJSON (Identify token intent shard) = object [ - "op" .= (2 :: Int) - , "d" .= object [ - "token" .= authToken token + toJSON (Heartbeat i) = + object ["op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i] + toJSON (Identify token intent shard) = object + [ "op" .= (2 :: Int) + , "d" .= object + [ "token" .= authToken token , "intents" .= compileGatewayIntent intent - , "properties" .= object [ - "$os" .= os - , "$browser" .= ("discord-haskell" :: T.Text) - , "$device" .= ("discord-haskell" :: T.Text) - , "$referrer" .= ("" :: T.Text) - , "$referring_domain" .= ("" :: T.Text) + , "properties" .= object + [ "$os" .= os + , "$browser" .= ("discord-haskell" :: T.Text) + , "$device" .= ("discord-haskell" :: T.Text) + , "$referrer" .= ("" :: T.Text) + , "$referring_domain" .= ("" :: T.Text) ] , "compress" .= False , "large_threshold" .= (50 :: Int) -- stop sending offline members over 50 , "shard" .= shard ] ] - toJSON (Resume token session seqId) = object [ - "op" .= (6 :: Int) - , "d" .= object [ - "token" .= authToken token - , "session_id" .= session - , "seq" .= seqId - ] + toJSON (Resume token session seqId) = object + [ "op" .= (6 :: Int) + , "d" .= object + ["token" .= authToken token, "session_id" .= session, "seq" .= seqId] ] instance ToJSON GatewaySendable where - toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [ - "op" .= (3 :: Int) - , "d" .= object [ - "since" .= (since <&> \s -> 1000 * utcTimeToPOSIXSeconds s) -- takes UTCTime and returns unix time (in milliseconds) + toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object + [ "op" .= (3 :: Int) + , "d" .= object + [ "since" .= (since <&> \s -> 1000 * utcTimeToPOSIXSeconds s) -- takes UTCTime and returns unix time (in milliseconds) , "afk" .= afk , "status" .= statusString status - , "game" .= (game <&> \a -> object [ - "name" .= activityName a - , "type" .= fromDiscordType (activityType a) - , "url" .= activityUrl a - ]) + , "game" + .= (game <&> \a -> object + [ "name" .= activityName a + , "type" .= fromDiscordType (activityType a) + , "url" .= activityUrl a + ] + ) ] ] toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) = - object [ - "op" .= (4 :: Int) - , "d" .= object [ - "guild_id" .= guild - , "channel_id" .= channel - , "self_mute" .= mute - , "self_deaf" .= deaf + object + [ "op" .= (4 :: Int) + , "d" .= object + [ "guild_id" .= guild + , "channel_id" .= channel + , "self_mute" .= mute + , "self_deaf" .= deaf + ] ] - ] toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) = - object [ - "op" .= (8 :: Int) - , "d" .= object [ - "guild_id" .= guild - , "query" .= query - , "limit" .= limit + object + [ "op" .= (8 :: Int) + , "d" .= object ["guild_id" .= guild, "query" .= query, "limit" .= limit] ] - ] diff --git a/src/Discord/Internal/Types/Guild.hs b/src/Discord/Internal/Types/Guild.hs index 78ccca9b..6993ddd1 100644 --- a/src/Discord/Internal/Types/Guild.hs +++ b/src/Discord/Internal/Types/Guild.hs @@ -5,18 +5,22 @@ -- | Types relating to Discord Guilds (servers) module Discord.Internal.Types.Guild where -import Data.Time.Clock +import Data.Time.Clock -import Data.Aeson -import qualified Data.Text as T -import Data.Data (Data) -import Data.Default (Default(..)) +import Data.Aeson +import Data.Data ( Data ) +import Data.Default ( Default(..) ) +import qualified Data.Text as T -import Discord.Internal.Types.Prelude -import Discord.Internal.Types.Color (DiscordColor) -import Discord.Internal.Types.Channel (Channel) -import Discord.Internal.Types.User (User, GuildMember) -import Discord.Internal.Types.Emoji (Emoji, StickerItem) +import Discord.Internal.Types.Channel ( Channel ) +import Discord.Internal.Types.Color ( DiscordColor ) +import Discord.Internal.Types.Emoji ( Emoji + , StickerItem + ) +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User ( GuildMember + , User + ) @@ -25,119 +29,168 @@ import Discord.Internal.Types.Emoji (Emoji, StickerItem) -- -- https://discord.com/developers/docs/resources/guild#guild-object data Guild = Guild - { guildId :: GuildId -- ^ Gulid id - , guildName :: T.Text -- ^ Guild name (2 - 100 chars) - , guildIcon :: Maybe T.Text -- ^ Icon hash - , guildIconHash :: Maybe T.Text -- ^ Icon hash, when returned in template object - , guildSplash :: Maybe T.Text -- ^ Splash hash - , guildDiscoverySplash :: Maybe T.Text -- ^ Discovery splash hash - , guildOwner :: Maybe Bool -- ^ True is user is the owner of the guild - , guildOwnerId :: UserId -- ^ Guild owner id - , guildPermissions :: Maybe T.Text -- ^ Total permissions for the user in the guild - , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel - , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds - , guildWidgetEnabled :: Maybe Bool -- ^ Id of embedded channel - , guildWidgetChannelId :: Maybe ChannelId -- ^ Id of embedded channel - , guildVerificationLevel :: Integer -- ^ Level of verification - , guildNotification :: Integer -- ^ Level of default notifications - , guildExplicitFilterLevel :: Integer -- ^ Whose media gets scanned - , guildRoles :: [Role] -- ^ Array of 'Role' objects - , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects - , guildFeatures :: [T.Text] -- ^ Array of guild feature strings - , guildMultiFactAuth :: !Integer -- ^ MFA level for the guild - , guildApplicationId :: Maybe ApplicationId -- ^ Application id of the guild if bot created - , guildSystemChannelId :: Maybe ChannelId -- ^ Channel where guild notices such as welcome messages and boost events - , guildSystemChannelFlags :: Integer -- ^ Flags on the system channel - , guildRulesChannelId :: Maybe ChannelId -- ^ Id of channel with rules/guidelines - , guildJoinedAt :: Maybe UTCTime -- ^ When this guild was joined at - , guildLarge :: Maybe Bool -- ^ True if this guild is considered large - , guildUnavailable :: Maybe Bool -- ^ True if the guild is unavailable due to outage - , guildMemberCount :: Maybe Integer -- ^ Total number of members in the guild + { guildId :: GuildId -- ^ Gulid id + , guildName :: T.Text -- ^ Guild name (2 - 100 chars) + , guildIcon :: Maybe T.Text -- ^ Icon hash + , guildIconHash :: Maybe T.Text -- ^ Icon hash, when returned in template object + , guildSplash :: Maybe T.Text -- ^ Splash hash + , guildDiscoverySplash :: Maybe T.Text -- ^ Discovery splash hash + , guildOwner :: Maybe Bool -- ^ True is user is the owner of the guild + , guildOwnerId :: UserId -- ^ Guild owner id + , guildPermissions :: Maybe T.Text -- ^ Total permissions for the user in the guild + , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel + , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds + , guildWidgetEnabled :: Maybe Bool -- ^ Id of embedded channel + , guildWidgetChannelId :: Maybe ChannelId -- ^ Id of embedded channel + , guildVerificationLevel :: Integer -- ^ Level of verification + , guildNotification :: Integer -- ^ Level of default notifications + , guildExplicitFilterLevel :: Integer -- ^ Whose media gets scanned + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + , guildFeatures :: [T.Text] -- ^ Array of guild feature strings + , guildMultiFactAuth :: !Integer -- ^ MFA level for the guild + , guildApplicationId :: Maybe ApplicationId -- ^ Application id of the guild if bot created + , guildSystemChannelId :: Maybe ChannelId -- ^ Channel where guild notices such as welcome messages and boost events + , guildSystemChannelFlags :: Integer -- ^ Flags on the system channel + , guildRulesChannelId :: Maybe ChannelId -- ^ Id of channel with rules/guidelines + , guildJoinedAt :: Maybe UTCTime -- ^ When this guild was joined at + , guildLarge :: Maybe Bool -- ^ True if this guild is considered large + , guildUnavailable :: Maybe Bool -- ^ True if the guild is unavailable due to outage + , guildMemberCount :: Maybe Integer -- ^ Total number of members in the guild -- voice_states - , guildMembers :: Maybe [GuildMember] -- ^ Users in the guild - , guildChannels :: Maybe [Channel] -- ^ Channels in the guild - , guildThreads :: Maybe [Channel] -- ^ All active threads in the guild that the current user has permission to view - , guildPresences :: Maybe [PresenceInfo] -- ^ Presences of the members in the guild - , guildMaxPresences :: Maybe Integer -- ^ Maximum number of prescences in the guild - , guildMaxMembers :: Maybe Integer -- ^ Maximum number of members in the guild - , guildVanityURL :: Maybe T.Text -- ^ Vanity url code for the guild - , guildDescription :: Maybe T.Text -- ^ Description of a commmunity guild - , guildBanner :: Maybe T.Text -- ^ Banner hash - , guildPremiumTier :: Integer -- ^ Premium tier (boost level) - , guildSubscriptionCount :: Maybe Integer -- ^ Number of boosts the guild has - , guildPreferredLocale :: T.Text -- ^ Preferred locale of a community server - , guildPublicUpdatesChannel :: Maybe ChannelId -- ^ Id of channel where admins and mods get updates - , guildMaxVideoUsers :: Maybe Integer -- ^ Maximum number of users in video channel - , guildApproxMemberCount :: Maybe Integer -- ^ Approximate number of members in the guild - , guildApproxPresenceCount :: Maybe Integer -- ^ Approximate number of non-offline members in the guild + , guildMembers :: Maybe [GuildMember] -- ^ Users in the guild + , guildChannels :: Maybe [Channel] -- ^ Channels in the guild + , guildThreads :: Maybe [Channel] -- ^ All active threads in the guild that the current user has permission to view + , guildPresences :: Maybe [PresenceInfo] -- ^ Presences of the members in the guild + , guildMaxPresences :: Maybe Integer -- ^ Maximum number of prescences in the guild + , guildMaxMembers :: Maybe Integer -- ^ Maximum number of members in the guild + , guildVanityURL :: Maybe T.Text -- ^ Vanity url code for the guild + , guildDescription :: Maybe T.Text -- ^ Description of a commmunity guild + , guildBanner :: Maybe T.Text -- ^ Banner hash + , guildPremiumTier :: Integer -- ^ Premium tier (boost level) + , guildSubscriptionCount :: Maybe Integer -- ^ Number of boosts the guild has + , guildPreferredLocale :: T.Text -- ^ Preferred locale of a community server + , guildPublicUpdatesChannel :: Maybe ChannelId -- ^ Id of channel where admins and mods get updates + , guildMaxVideoUsers :: Maybe Integer -- ^ Maximum number of users in video channel + , guildApproxMemberCount :: Maybe Integer -- ^ Approximate number of members in the guild + , guildApproxPresenceCount :: Maybe Integer -- ^ Approximate number of non-offline members in the guild -- welcome_screen - , guildNSFWLevel :: Integer -- ^ Guild NSFW level + , guildNSFWLevel :: Integer -- ^ Guild NSFW level -- stage_instances - , guildStickers :: Maybe [StickerItem] -- ^ Custom guild stickers + , guildStickers :: Maybe [StickerItem] -- ^ Custom guild stickers -- guild_scheduled_events - , guildPremiumBar :: Bool -- ^ Whether the guild has the boost progress bar enabled - } deriving (Show, Read, Eq, Ord) + , guildPremiumBar :: Bool -- ^ Whether the guild has the boost progress bar enabled + } + deriving (Show, Read, Eq, Ord) instance FromJSON Guild where parseJSON = withObject "Guild" $ \o -> - Guild <$> o .: "id" - <*> o .: "name" - <*> o .:? "icon" - <*> o .:? "icon_hash" - <*> o .:? "splash" - <*> o .:? "discovery_splash" - <*> o .:? "owner" - <*> o .: "owner_id" - <*> o .:? "permissions" - <*> o .:? "afk_channel_id" - <*> o .: "afk_timeout" - <*> o .:? "widget_enabled" - <*> o .:? "widget_channel_id" - <*> o .: "verification_level" - <*> o .: "default_message_notifications" - <*> o .: "explicit_content_filter" - <*> o .: "roles" - <*> o .: "emojis" - <*> o .: "features" - <*> o .: "mfa_level" - <*> o .:? "application_id" - <*> o .:? "system_channel_id" - <*> o .: "system_channel_flags" - <*> o .:? "rules_channel_id" - <*> o .:? "joined_at" - <*> o .:? "large" - <*> o .:? "unavailable" - <*> o .:? "member_count" + Guild + <$> o + .: "id" + <*> o + .: "name" + <*> o + .:? "icon" + <*> o + .:? "icon_hash" + <*> o + .:? "splash" + <*> o + .:? "discovery_splash" + <*> o + .:? "owner" + <*> o + .: "owner_id" + <*> o + .:? "permissions" + <*> o + .:? "afk_channel_id" + <*> o + .: "afk_timeout" + <*> o + .:? "widget_enabled" + <*> o + .:? "widget_channel_id" + <*> o + .: "verification_level" + <*> o + .: "default_message_notifications" + <*> o + .: "explicit_content_filter" + <*> o + .: "roles" + <*> o + .: "emojis" + <*> o + .: "features" + <*> o + .: "mfa_level" + <*> o + .:? "application_id" + <*> o + .:? "system_channel_id" + <*> o + .: "system_channel_flags" + <*> o + .:? "rules_channel_id" + <*> o + .:? "joined_at" + <*> o + .:? "large" + <*> o + .:? "unavailable" + <*> o + .:? "member_count" -- voice_states - <*> o .:? "members" - <*> o .:? "channels" - <*> o .:? "threads" - <*> o .:? "presences" - <*> o .:? "max_presences" - <*> o .:? "max_members" - <*> o .:? "vanity_url_code" - <*> o .:? "description" - <*> o .:? "banner" - <*> o .: "premium_tier" - <*> o .:? "premium_subscription_count" - <*> o .: "preferred_locale" - <*> o .:? "public_updates_channel_id" - <*> o .:? "max_video_channel_users" - <*> o .:? "approximate_member_count" - <*> o .:? "approximate_presence_count" + <*> o + .:? "members" + <*> o + .:? "channels" + <*> o + .:? "threads" + <*> o + .:? "presences" + <*> o + .:? "max_presences" + <*> o + .:? "max_members" + <*> o + .:? "vanity_url_code" + <*> o + .:? "description" + <*> o + .:? "banner" + <*> o + .: "premium_tier" + <*> o + .:? "premium_subscription_count" + <*> o + .: "preferred_locale" + <*> o + .:? "public_updates_channel_id" + <*> o + .:? "max_video_channel_users" + <*> o + .:? "approximate_member_count" + <*> o + .:? "approximate_presence_count" -- welcome_screen - <*> o .: "nsfw_level" + <*> o + .: "nsfw_level" -- stage_instances - <*> o .:? "stickers" - <*> o .: "premium_progress_bar_enabled" + <*> o + .:? "stickers" + <*> o + .: "premium_progress_bar_enabled" newtype GuildUnavailable = GuildUnavailable { idOnceAvailable :: GuildId } deriving (Show, Read, Eq, Ord) instance FromJSON GuildUnavailable where - parseJSON = withObject "GuildUnavailable" $ \o -> - GuildUnavailable <$> o .: "id" + parseJSON = + withObject "GuildUnavailable" $ \o -> GuildUnavailable <$> o .: "id" data PresenceInfo = PresenceInfo { presenceUserId :: UserId @@ -145,14 +198,19 @@ data PresenceInfo = PresenceInfo , presenceActivities :: Maybe [Activity] , presenceGuildId :: Maybe GuildId , presenceStatus :: T.Text - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON PresenceInfo where parseJSON = withObject "PresenceInfo" $ \o -> - PresenceInfo <$> (o .: "user" >>= (.: "id")) - <*> o .: "activities" - <*> o .:? "guild_id" - <*> o .: "status" + PresenceInfo + <$> (o .: "user" >>= (.: "id")) + <*> o + .: "activities" + <*> o + .:? "guild_id" + <*> o + .: "status" -- | Object for a single activity -- @@ -160,80 +218,105 @@ instance FromJSON PresenceInfo where -- -- When setting a bot's activity, only the name, url, and type are sent - and -- it seems that not many types are permitted either. -data Activity = - Activity - { activityName :: T.Text -- ^ Name of activity - , activityType :: ActivityType -- ^ Type of activity - , activityUrl :: Maybe T.Text -- ^ URL of the activity (only verified when streaming) - , activityCreatedAt :: Integer -- ^ unix time in milliseconds - , activityTimeStamps :: Maybe ActivityTimestamps -- ^ Start and end times - , activityApplicationId :: Maybe ApplicationId -- ^ Application of the activity - , activityDetails :: Maybe T.Text -- ^ Details of Activity - , activityState :: Maybe T.Text -- ^ State of the user's party - , activityEmoji :: Maybe Emoji -- ^ Simplified emoji object - , activityParty :: Maybe ActivityParty -- ^ Info for the current player's party - -- assets - -- secrets - , activityInstance :: Maybe Bool -- ^ Whether or not the activity is an instanced game session - , activityFlags :: Maybe Integer -- ^ The flags https://discord.com/developers/docs/topics/gateway#activity-object-activity-flags - , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence - } +data Activity = Activity + { activityName :: T.Text -- ^ Name of activity + , activityType :: ActivityType -- ^ Type of activity + , activityUrl :: Maybe T.Text -- ^ URL of the activity (only verified when streaming) + , activityCreatedAt :: Integer -- ^ unix time in milliseconds + , activityTimeStamps :: Maybe ActivityTimestamps -- ^ Start and end times + , activityApplicationId :: Maybe ApplicationId -- ^ Application of the activity + , activityDetails :: Maybe T.Text -- ^ Details of Activity + , activityState :: Maybe T.Text -- ^ State of the user's party + , activityEmoji :: Maybe Emoji -- ^ Simplified emoji object + , activityParty :: Maybe ActivityParty -- ^ Info for the current player's party + -- assets + -- secrets + , activityInstance :: Maybe Bool -- ^ Whether or not the activity is an instanced game session + , activityFlags :: Maybe Integer -- ^ The flags https://discord.com/developers/docs/topics/gateway#activity-object-activity-flags + , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence + } deriving (Show, Read, Eq, Ord) instance Default Activity where - def = Activity "discord-haskell" ActivityTypeGame Nothing 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + def = Activity "discord-haskell" + ActivityTypeGame + Nothing + 0 + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing instance FromJSON Activity where parseJSON = withObject "Activity" $ \o -> do - Activity <$> o .: "name" - <*> o .: "type" - <*> o .:? "url" - <*> o .: "created_at" - <*> o .:? "timestamps" - <*> o .:? "application_id" - <*> o .:? "details" - <*> o .:? "state" - <*> o .:? "emoji" - <*> o .:? "party" + Activity + <$> o + .: "name" + <*> o + .: "type" + <*> o + .:? "url" + <*> o + .: "created_at" + <*> o + .:? "timestamps" + <*> o + .:? "application_id" + <*> o + .:? "details" + <*> o + .:? "state" + <*> o + .:? "emoji" + <*> o + .:? "party" -- assets -- secrets - <*> o .:? "instance" - <*> o .:? "flags" - <*> o .:? "buttons" + <*> o + .:? "instance" + <*> o + .:? "flags" + <*> o + .:? "buttons" data ActivityTimestamps = ActivityTimestamps { activityTimestampsStart :: Maybe Integer -- ^ unix time in milliseconds - , activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds - } deriving (Show, Read, Eq, Ord) + , activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds + } + deriving (Show, Read, Eq, Ord) instance FromJSON ActivityTimestamps where - parseJSON = withObject "ActivityTimestamps" $ \o -> - ActivityTimestamps <$> o .:? "start" - <*> o .:? "end" + parseJSON = withObject "ActivityTimestamps" + $ \o -> ActivityTimestamps <$> o .:? "start" <*> o .:? "end" data ActivityParty = ActivityParty - { activityPartyId :: Maybe T.Text + { activityPartyId :: Maybe T.Text , activityPartySize :: Maybe (Integer, Integer) - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON ActivityParty where - parseJSON = withObject "ActivityParty" $ \o -> - ActivityParty <$> o .:? "id" - <*> o .:? "size" + parseJSON = withObject "ActivityParty" + $ \o -> ActivityParty <$> o .:? "id" <*> o .:? "size" data ActivityButton = ActivityButton { activityButtonLabel :: T.Text - , activityButtonUrl :: T.Text - } deriving (Show, Read, Eq, Ord) + , activityButtonUrl :: T.Text + } + deriving (Show, Read, Eq, Ord) instance FromJSON ActivityButton where - parseJSON = withObject "ActivityButton" $ \o -> - ActivityButton <$> o .: "label" - <*> o .: "url" + parseJSON = withObject "ActivityButton" + $ \o -> ActivityButton <$> o .: "label" <*> o .: "url" -- | To see what these look like, go to here: -- https://discord.com/developers/docs/topics/gateway#activity-object-activity-types -data ActivityType = +data ActivityType = ActivityTypeGame | ActivityTypeStreaming | ActivityTypeListening @@ -244,102 +327,135 @@ data ActivityType = instance InternalDiscordEnum ActivityType where discordTypeStartValue = ActivityTypeGame - fromDiscordType ActivityTypeGame = 0 + fromDiscordType ActivityTypeGame = 0 fromDiscordType ActivityTypeStreaming = 1 fromDiscordType ActivityTypeListening = 2 - fromDiscordType ActivityTypeWatching = 3 - fromDiscordType ActivityTypeCustom = 4 + fromDiscordType ActivityTypeWatching = 3 + fromDiscordType ActivityTypeCustom = 4 fromDiscordType ActivityTypeCompeting = 5 instance FromJSON ActivityType where parseJSON = discordTypeParseJSON "ActivityType" data PartialGuild = PartialGuild - { partialGuildId :: GuildId - , partialGuildName :: T.Text - , partialGuildIcon :: Maybe T.Text - , partialGuildOwner :: Bool - , partialGuildPermissions :: T.Text - } deriving (Show, Read, Eq, Ord) + { partialGuildId :: GuildId + , partialGuildName :: T.Text + , partialGuildIcon :: Maybe T.Text + , partialGuildOwner :: Bool + , partialGuildPermissions :: T.Text + } + deriving (Show, Read, Eq, Ord) instance FromJSON PartialGuild where parseJSON = withObject "PartialGuild" $ \o -> - PartialGuild <$> o .: "id" - <*> o .: "name" - <*> o .:? "icon" - <*> o .:? "owner" .!= False - <*> o .: "permissions" + PartialGuild + <$> o + .: "id" + <*> o + .: "name" + <*> o + .:? "icon" + <*> o + .:? "owner" + .!= False + <*> o + .: "permissions" -- | Roles represent a set of permissions attached to a group of users. Roles have unique -- names, colors, and can be "pinned" to the side bar, causing their members to be listed separately. -- Roles are unique per guild, and can have separate permission profiles for the global context -- (guild) and channel context. -data Role = - Role { - roleId :: RoleId -- ^ The role id - , roleName :: T.Text -- ^ The role name - , roleColor :: DiscordColor -- ^ Integer representation of color code - , roleHoist :: Bool -- ^ If the role is pinned in the user listing - , rolePos :: Integer -- ^ Position of this role - , rolePerms :: T.Text -- ^ Permission bit set - , roleManaged :: Bool -- ^ Whether this role is managed by an integration - , roleMention :: Bool -- ^ Whether this role is mentionable - } deriving (Show, Read, Eq, Ord) +data Role = Role + { roleId :: RoleId -- ^ The role id + , roleName :: T.Text -- ^ The role name + , roleColor :: DiscordColor -- ^ Integer representation of color code + , roleHoist :: Bool -- ^ If the role is pinned in the user listing + , rolePos :: Integer -- ^ Position of this role + , rolePerms :: T.Text -- ^ Permission bit set + , roleManaged :: Bool -- ^ Whether this role is managed by an integration + , roleMention :: Bool -- ^ Whether this role is mentionable + } + deriving (Show, Read, Eq, Ord) instance FromJSON Role where parseJSON = withObject "Role" $ \o -> - Role <$> o .: "id" - <*> o .: "name" - <*> o .: "color" - <*> o .: "hoist" - <*> o .: "position" - <*> o .: "permissions" - <*> o .: "managed" - <*> o .: "mentionable" + Role + <$> o + .: "id" + <*> o + .: "name" + <*> o + .: "color" + <*> o + .: "hoist" + <*> o + .: "position" + <*> o + .: "permissions" + <*> o + .: "managed" + <*> o + .: "mentionable" -- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added data VoiceRegion = VoiceRegion - { voiceRegionId :: T.Text -- ^ Unique id of the region - , voiceRegionName :: T.Text -- ^ Name of the region - , voiceRegionVip :: Bool -- ^ True if this is a VIP only server - , voiceRegionOptimal :: Bool -- ^ True for the closest server to a client - , voiceRegionDeprecated :: Bool -- ^ Whether this is a deprecated region - , voiceRegionCustom :: Bool -- ^ Whether this is a custom region - } deriving (Show, Read, Eq, Ord) + { voiceRegionId :: T.Text -- ^ Unique id of the region + , voiceRegionName :: T.Text -- ^ Name of the region + , voiceRegionVip :: Bool -- ^ True if this is a VIP only server + , voiceRegionOptimal :: Bool -- ^ True for the closest server to a client + , voiceRegionDeprecated :: Bool -- ^ Whether this is a deprecated region + , voiceRegionCustom :: Bool -- ^ Whether this is a custom region + } + deriving (Show, Read, Eq, Ord) instance FromJSON VoiceRegion where parseJSON = withObject "VoiceRegion" $ \o -> - VoiceRegion <$> o .: "id" - <*> o .: "name" - <*> o .: "vip" - <*> o .: "optimal" - <*> o .: "deprecated" - <*> o .: "custom" + VoiceRegion + <$> o + .: "id" + <*> o + .: "name" + <*> o + .: "vip" + <*> o + .: "optimal" + <*> o + .: "deprecated" + <*> o + .: "custom" -- | Info about a Ban data GuildBan = GuildBan - { guildBanReason :: T.Text - , guildBanUser :: User - } deriving (Show, Read, Eq, Ord) + { guildBanReason :: T.Text + , guildBanUser :: User + } + deriving (Show, Read, Eq, Ord) instance FromJSON GuildBan where - parseJSON = withObject "GuildBan" $ \o -> GuildBan <$> o .: "reason" <*> o .: "user" + parseJSON = + withObject "GuildBan" $ \o -> GuildBan <$> o .: "reason" <*> o .: "user" -- | Represents a code to add a user to a guild data Invite = Invite - { inviteCode :: T.Text -- ^ The invite code - , inviteGuildId :: Maybe GuildId -- ^ The guild the code will invite to - , inviteChannelId :: ChannelId -- ^ The channel the code will invite to - } deriving (Show, Read, Eq, Ord) + { inviteCode :: T.Text -- ^ The invite code + , inviteGuildId :: Maybe GuildId -- ^ The guild the code will invite to + , inviteChannelId :: ChannelId -- ^ The channel the code will invite to + } + deriving (Show, Read, Eq, Ord) instance FromJSON Invite where parseJSON = withObject "Invite" $ \o -> - Invite <$> o .: "code" - <*> (do g <- o .:? "guild" - case g of Just g2 -> g2 .: "id" - Nothing -> pure Nothing) - <*> ((o .: "channel") >>= (.: "id")) + Invite + <$> o + .: "code" + <*> (do + g <- o .:? "guild" + case g of + Just g2 -> g2 .: "id" + Nothing -> pure Nothing + ) + <*> ((o .: "channel") >>= (.: "id")) -- | Invite code with additional metadata data InviteWithMeta = InviteWithMeta Invite InviteMeta @@ -349,76 +465,98 @@ instance FromJSON InviteWithMeta where -- | Additional metadata about an invite. data InviteMeta = InviteMeta - { inviteCreator :: User -- ^ The user that created the invite - , inviteUses :: Integer -- ^ Number of times the invite has been used - , inviteMax :: Integer -- ^ Max number of times the invite can be used - , inviteAge :: Integer -- ^ The duration (in seconds) after which the invite expires - , inviteTemp :: Bool -- ^ Whether this invite only grants temporary membership - , inviteCreated :: UTCTime -- ^ When the invite was created - , inviteRevoked :: Bool -- ^ If the invite is revoked - } deriving (Show, Read, Eq, Ord) + { inviteCreator :: User -- ^ The user that created the invite + , inviteUses :: Integer -- ^ Number of times the invite has been used + , inviteMax :: Integer -- ^ Max number of times the invite can be used + , inviteAge :: Integer -- ^ The duration (in seconds) after which the invite expires + , inviteTemp :: Bool -- ^ Whether this invite only grants temporary membership + , inviteCreated :: UTCTime -- ^ When the invite was created + , inviteRevoked :: Bool -- ^ If the invite is revoked + } + deriving (Show, Read, Eq, Ord) instance FromJSON InviteMeta where parseJSON = withObject "InviteMeta" $ \o -> - InviteMeta <$> o .: "inviter" - <*> o .: "uses" - <*> o .: "max_uses" - <*> o .: "max_age" - <*> o .: "temporary" - <*> o .: "created_at" - <*> o .: "revoked" + InviteMeta + <$> o + .: "inviter" + <*> o + .: "uses" + <*> o + .: "max_uses" + <*> o + .: "max_age" + <*> o + .: "temporary" + <*> o + .: "created_at" + <*> o + .: "revoked" -- | Represents the behavior of a third party account link. data Integration = Integration - { integrationId :: !Snowflake -- ^ Integration id - , integrationName :: T.Text -- ^ Integration name - , integrationType :: T.Text -- ^ Integration type (Twitch, Youtube, ect.) - , integrationEnabled :: Bool -- ^ Is the integration enabled - , integrationSyncing :: Bool -- ^ Is the integration syncing - , integrationRole :: RoleId -- ^ Id the integration uses for "subscribers" - , integrationBehavior :: Integer -- ^ The behavior of expiring subscribers - , integrationGrace :: Integer -- ^ The grace period before expiring subscribers - , integrationOwner :: User -- ^ The user of the integration - , integrationAccount :: IntegrationAccount -- ^ The account the integration links to - , integrationSync :: UTCTime -- ^ When the integration was last synced - } deriving (Show, Read, Eq, Ord) + { integrationId :: !Snowflake -- ^ Integration id + , integrationName :: T.Text -- ^ Integration name + , integrationType :: T.Text -- ^ Integration type (Twitch, Youtube, ect.) + , integrationEnabled :: Bool -- ^ Is the integration enabled + , integrationSyncing :: Bool -- ^ Is the integration syncing + , integrationRole :: RoleId -- ^ Id the integration uses for "subscribers" + , integrationBehavior :: Integer -- ^ The behavior of expiring subscribers + , integrationGrace :: Integer -- ^ The grace period before expiring subscribers + , integrationOwner :: User -- ^ The user of the integration + , integrationAccount :: IntegrationAccount -- ^ The account the integration links to + , integrationSync :: UTCTime -- ^ When the integration was last synced + } + deriving (Show, Read, Eq, Ord) instance FromJSON Integration where parseJSON = withObject "Integration" $ \o -> - Integration <$> o .: "id" - <*> o .: "name" - <*> o .: "type" - <*> o .: "enabled" - <*> o .: "syncing" - <*> o .: "role_id" - <*> o .: "expire_behavior" - <*> o .: "expire_grace_period" - <*> o .: "user" - <*> o .: "account" - <*> o .: "synced_at" + Integration + <$> o + .: "id" + <*> o + .: "name" + <*> o + .: "type" + <*> o + .: "enabled" + <*> o + .: "syncing" + <*> o + .: "role_id" + <*> o + .: "expire_behavior" + <*> o + .: "expire_grace_period" + <*> o + .: "user" + <*> o + .: "account" + <*> o + .: "synced_at" -- | Represents a third party account link. data IntegrationAccount = IntegrationAccount - { accountId :: T.Text -- ^ The id of the account. - , accountName :: T.Text -- ^ The name of the account. - } deriving (Show, Read, Eq, Ord) + { accountId :: T.Text -- ^ The id of the account. + , accountName :: T.Text -- ^ The name of the account. + } + deriving (Show, Read, Eq, Ord) instance FromJSON IntegrationAccount where - parseJSON = withObject "IntegrationAccount" $ \o -> - IntegrationAccount <$> o .: "id" <*> o .: "name" + parseJSON = withObject "IntegrationAccount" + $ \o -> IntegrationAccount <$> o .: "id" <*> o .: "name" -- | Represents an image to be used in third party sites to link to a discord channel data GuildWidget = GuildWidget - { widgetEnabled :: Bool -- ^ Whether the widget is enabled - , widgetChannelId :: ChannelId -- ^ The widget channel id - } deriving (Show, Read, Eq, Ord) + { widgetEnabled :: Bool -- ^ Whether the widget is enabled + , widgetChannelId :: ChannelId -- ^ The widget channel id + } + deriving (Show, Read, Eq, Ord) instance FromJSON GuildWidget where - parseJSON = withObject "GuildWidget" $ \o -> - GuildWidget <$> o .: "enabled" <*> o .: "channel_id" + parseJSON = withObject "GuildWidget" + $ \o -> GuildWidget <$> o .: "enabled" <*> o .: "channel_id" instance ToJSON GuildWidget where - toJSON (GuildWidget enabled snowflake) = object - [ "enabled" .= enabled - , "channel_id" .= snowflake - ] + toJSON (GuildWidget enabled snowflake) = + object ["enabled" .= enabled, "channel_id" .= snowflake] diff --git a/src/Discord/Internal/Types/Interactions.hs b/src/Discord/Internal/Types/Interactions.hs index 00e06b06..d3ddaf80 100644 --- a/src/Discord/Internal/Types/Interactions.hs +++ b/src/Discord/Internal/Types/Interactions.hs @@ -8,41 +8,61 @@ {-# LANGUAGE RecordWildCards #-} module Discord.Internal.Types.Interactions - ( Interaction (..), - InteractionDataComponent (..), - InteractionDataApplicationCommand (..), - InteractionDataApplicationCommandOptions (..), - InteractionDataApplicationCommandOptionSubcommandOrGroup (..), - InteractionDataApplicationCommandOptionSubcommand (..), - InteractionDataApplicationCommandOptionValue (..), - InteractionToken, - ResolvedData (..), - MemberOrUser (..), - InteractionResponse (..), - interactionResponseBasic, - InteractionResponseAutocomplete (..), - InteractionResponseMessage (..), - interactionResponseMessageBasic, - InteractionResponseMessageFlags (..), - InteractionResponseMessageFlag (..), - InteractionResponseModalData (..), - ) -where - -import Control.Applicative (Alternative ((<|>))) -import Control.Monad (join) -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Bits (Bits (shift, (.|.))) -import Data.Foldable (Foldable (toList)) -import Data.Scientific (Scientific) -import qualified Data.Text as T -import Discord.Internal.Types.ApplicationCommands (Choice) -import Discord.Internal.Types.Channel (AllowedMentions, Attachment, Message) -import Discord.Internal.Types.Components (ComponentActionRow, ComponentTextInput) -import Discord.Internal.Types.Embed (CreateEmbed, createEmbed) -import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, ChannelId, GuildId, InteractionId, InteractionToken, MessageId, RoleId, Snowflake, UserId) -import Discord.Internal.Types.User (GuildMember, User) + ( Interaction(..) + , InteractionDataComponent(..) + , InteractionDataApplicationCommand(..) + , InteractionDataApplicationCommandOptions(..) + , InteractionDataApplicationCommandOptionSubcommandOrGroup(..) + , InteractionDataApplicationCommandOptionSubcommand(..) + , InteractionDataApplicationCommandOptionValue(..) + , InteractionToken + , ResolvedData(..) + , MemberOrUser(..) + , InteractionResponse(..) + , interactionResponseBasic + , InteractionResponseAutocomplete(..) + , InteractionResponseMessage(..) + , interactionResponseMessageBasic + , InteractionResponseMessageFlags(..) + , InteractionResponseMessageFlag(..) + , InteractionResponseModalData(..) + ) where + +import Control.Applicative ( Alternative((<|>)) ) +import Control.Monad ( join ) +import Data.Aeson +import Data.Aeson.Types ( Parser ) +import Data.Bits ( Bits((.|.), shift) ) +import Data.Foldable ( Foldable(toList) ) +import Data.Scientific ( Scientific ) +import qualified Data.Text as T +import Discord.Internal.Types.ApplicationCommands + ( Choice ) +import Discord.Internal.Types.Channel ( AllowedMentions + , Attachment + , Message + ) +import Discord.Internal.Types.Components + ( ComponentActionRow + , ComponentTextInput + ) +import Discord.Internal.Types.Embed ( CreateEmbed + , createEmbed + ) +import Discord.Internal.Types.Prelude ( ApplicationCommandId + , ApplicationId + , ChannelId + , GuildId + , InteractionId + , InteractionToken + , MessageId + , RoleId + , Snowflake + , UserId + ) +import Discord.Internal.Types.User ( GuildMember + , User + ) -- | An interaction received from discord. data Interaction @@ -149,73 +169,81 @@ data Interaction deriving (Show, Read, Eq, Ord) instance FromJSON Interaction where - parseJSON = - withObject - "Interaction" - ( \v -> do - iid <- v .: "id" - aid <- v .: "application_id" - gid <- v .:? "guild_id" - cid <- v .:? "channel_id" - tok <- v .: "token" - version <- v .: "version" - glocale <- v .:? "guild_locale" - t <- v .: "type" :: Parser Int - case t of - 1 -> return $ InteractionPing iid aid tok version - 2 -> - InteractionApplicationCommand iid aid - <$> v .: "data" - <*> return gid - <*> return cid - <*> parseJSON (Object v) - <*> return tok - <*> return version - <*> v .: "locale" - <*> return glocale - 3 -> - InteractionComponent iid aid - <$> v .: "data" - <*> return gid - <*> return cid - <*> parseJSON (Object v) - <*> return tok - <*> return version - <*> v .: "message" - <*> v .: "locale" - <*> return glocale - 4 -> - InteractionApplicationCommandAutocomplete iid aid - <$> v .: "data" - <*> return gid - <*> return cid - <*> parseJSON (Object v) - <*> return tok - <*> return version - <*> v .: "locale" - <*> return glocale - 5 -> - InteractionModalSubmit iid aid - <$> v .: "data" - <*> return gid - <*> return cid - <*> parseJSON (Object v) - <*> return tok - <*> return version - <*> v .: "locale" - <*> return glocale - _ -> fail "unknown interaction type" - ) + parseJSON = withObject + "Interaction" + (\v -> do + iid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + cid <- v .:? "channel_id" + tok <- v .: "token" + version <- v .: "version" + glocale <- v .:? "guild_locale" + t <- v .: "type" :: Parser Int + case t of + 1 -> return $ InteractionPing iid aid tok version + 2 -> + InteractionApplicationCommand iid aid + <$> v + .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v + .: "locale" + <*> return glocale + 3 -> + InteractionComponent iid aid + <$> v + .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v + .: "message" + <*> v + .: "locale" + <*> return glocale + 4 -> + InteractionApplicationCommandAutocomplete iid aid + <$> v + .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v + .: "locale" + <*> return glocale + 5 -> + InteractionModalSubmit iid aid + <$> v + .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v + .: "locale" + <*> return glocale + _ -> fail "unknown interaction type" + ) newtype MemberOrUser = MemberOrUser (Either GuildMember User) deriving (Show, Read, Eq, Ord) instance {-# OVERLAPPING #-} FromJSON MemberOrUser where - parseJSON = - withObject - "MemberOrUser" - ( \v -> MemberOrUser <$> ((Left <$> v .: "member") <|> (Right <$> v .: "user")) - ) + parseJSON = withObject + "MemberOrUser" + (\v -> + MemberOrUser <$> ((Left <$> v .: "member") <|> (Right <$> v .: "user")) + ) data InteractionDataComponent = InteractionDataComponentButton @@ -231,19 +259,16 @@ data InteractionDataComponent deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataComponent where - parseJSON = - withObject - "InteractionDataComponent" - ( \v -> do - cid <- v .: "custom_id" - t <- v .: "component_type" :: Parser Int - case t of - 2 -> return $ InteractionDataComponentButton cid - 3 -> - InteractionDataComponentSelectMenu cid - <$> v .: "values" - _ -> fail "unknown interaction data component type" - ) + parseJSON = withObject + "InteractionDataComponent" + (\v -> do + cid <- v .: "custom_id" + t <- v .: "component_type" :: Parser Int + case t of + 2 -> return $ InteractionDataComponentButton cid + 3 -> InteractionDataComponentSelectMenu cid <$> v .: "values" + _ -> fail "unknown interaction data component type" + ) data InteractionDataApplicationCommand = InteractionDataApplicationCommandUser @@ -279,26 +304,26 @@ data InteractionDataApplicationCommand deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommand where - parseJSON = - withObject - "InteractionDataApplicationCommand" - ( \v -> do - aci <- v .: "id" - name <- v .: "name" - rd <- v .:? "resolved_data" - t <- v .: "type" :: Parser Int - case t of - 1 -> - InteractionDataApplicationCommandChatInput aci name rd - <$> v .:? "options" - 2 -> - InteractionDataApplicationCommandUser aci name rd - <$> v .: "target_id" - 3 -> - InteractionDataApplicationCommandMessage aci name rd - <$> v .: "target_id" - _ -> fail "unknown interaction data component type" - ) + parseJSON = withObject + "InteractionDataApplicationCommand" + (\v -> do + aci <- v .: "id" + name <- v .: "name" + rd <- v .:? "resolved_data" + t <- v .: "type" :: Parser Int + case t of + 1 -> + InteractionDataApplicationCommandChatInput aci name rd + <$> v + .:? "options" + 2 -> + InteractionDataApplicationCommandUser aci name rd <$> v .: "target_id" + 3 -> + InteractionDataApplicationCommandMessage aci name rd + <$> v + .: "target_id" + _ -> fail "unknown interaction data component type" + ) -- | Either subcommands and groups, or values. data InteractionDataApplicationCommandOptions @@ -307,24 +332,26 @@ data InteractionDataApplicationCommandOptions deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptions where - parseJSON = - withArray - "InteractionDataApplicationCommandOptions" - ( \a -> do - let a' = toList a - case a' of - [] -> return $ InteractionDataApplicationCommandOptionsValues [] - (v' : _) -> - withObject - "InteractionDataApplicationCommandOptions item" - ( \v -> do - t <- v .: "type" :: Parser Int - if t == 1 || t == 2 - then InteractionDataApplicationCommandOptionsSubcommands <$> mapM parseJSON a' - else InteractionDataApplicationCommandOptionsValues <$> mapM parseJSON a' - ) - v' - ) + parseJSON = withArray + "InteractionDataApplicationCommandOptions" + (\a -> do + let a' = toList a + case a' of + [] -> return $ InteractionDataApplicationCommandOptionsValues [] + (v' : _) -> withObject + "InteractionDataApplicationCommandOptions item" + (\v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then + InteractionDataApplicationCommandOptionsSubcommands + <$> mapM parseJSON a' + else + InteractionDataApplicationCommandOptionsValues + <$> mapM parseJSON a' + ) + v' + ) -- | Either a subcommand group or a subcommand. data InteractionDataApplicationCommandOptionSubcommandOrGroup @@ -337,43 +364,53 @@ data InteractionDataApplicationCommandOptionSubcommandOrGroup deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptionSubcommandOrGroup where - parseJSON = - withObject - "InteractionDataApplicationCommandOptionSubcommandOrGroup" - ( \v -> do - t <- v .: "type" :: Parser Int - case t of - 2 -> - InteractionDataApplicationCommandOptionSubcommandGroup - <$> v .: "name" - <*> v .: "options" - <*> v .:? "focused" .!= False - 1 -> InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand <$> parseJSON (Object v) - _ -> fail "unexpected subcommand group type" - ) + parseJSON = withObject + "InteractionDataApplicationCommandOptionSubcommandOrGroup" + (\v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + InteractionDataApplicationCommandOptionSubcommandGroup + <$> v + .: "name" + <*> v + .: "options" + <*> v + .:? "focused" + .!= False + 1 -> InteractionDataApplicationCommandOptionSubcommandOrGroupSubcommand + <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) -- | Data for a single subcommand. -data InteractionDataApplicationCommandOptionSubcommand = InteractionDataApplicationCommandOptionSubcommand - { interactionDataApplicationCommandOptionSubcommandName :: T.Text, - interactionDataApplicationCommandOptionSubcommandOptions :: [InteractionDataApplicationCommandOptionValue], - interactionDataApplicationCommandOptionSubcommandFocused :: Bool - } +data InteractionDataApplicationCommandOptionSubcommand + = InteractionDataApplicationCommandOptionSubcommand + { interactionDataApplicationCommandOptionSubcommandName :: T.Text + , interactionDataApplicationCommandOptionSubcommandOptions + :: [InteractionDataApplicationCommandOptionValue] + , interactionDataApplicationCommandOptionSubcommandFocused :: Bool + } deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptionSubcommand where - parseJSON = - withObject - "InteractionDataApplicationCommandOptionSubcommand" - ( \v -> do - t <- v .: "type" :: Parser Int - case t of - 1 -> - InteractionDataApplicationCommandOptionSubcommand - <$> v .: "name" - <*> v .:? "options" .!= [] - <*> v .:? "focused" .!= False - _ -> fail "unexpected subcommand type" - ) + parseJSON = withObject + "InteractionDataApplicationCommandOptionSubcommand" + (\v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + InteractionDataApplicationCommandOptionSubcommand + <$> v + .: "name" + <*> v + .:? "options" + .!= [] + <*> v + .:? "focused" + .!= False + _ -> fail "unexpected subcommand type" + ) -- | Data for a single value. data InteractionDataApplicationCommandOptionValue @@ -412,67 +449,72 @@ data InteractionDataApplicationCommandOptionValue deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataApplicationCommandOptionValue where - parseJSON = - withObject - "InteractionDataApplicationCommandOptionValue" - ( \v -> do - name <- v .: "name" - focused <- v .:? "focused" .!= False - t <- v .: "type" :: Parser Int - case t of - 3 -> - InteractionDataApplicationCommandOptionValueString name - <$> parseValue v focused - 4 -> - InteractionDataApplicationCommandOptionValueInteger name - <$> parseValue v focused - 10 -> - InteractionDataApplicationCommandOptionValueNumber name - <$> parseValue v focused - 5 -> - InteractionDataApplicationCommandOptionValueBoolean name - <$> v .: "value" - 6 -> - InteractionDataApplicationCommandOptionValueUser name - <$> v .: "value" - 7 -> - InteractionDataApplicationCommandOptionValueChannel name - <$> v .: "value" - 8 -> - InteractionDataApplicationCommandOptionValueRole name - <$> v .: "value" - 9 -> - InteractionDataApplicationCommandOptionValueMentionable name - <$> v .: "value" - _ -> fail $ "unexpected interaction data application command option value type: " ++ show t - ) + parseJSON = withObject + "InteractionDataApplicationCommandOptionValue" + (\v -> do + name <- v .: "name" + focused <- v .:? "focused" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + InteractionDataApplicationCommandOptionValueString name + <$> parseValue v focused + 4 -> + InteractionDataApplicationCommandOptionValueInteger name + <$> parseValue v focused + 10 -> + InteractionDataApplicationCommandOptionValueNumber name + <$> parseValue v focused + 5 -> + InteractionDataApplicationCommandOptionValueBoolean name + <$> v + .: "value" + 6 -> + InteractionDataApplicationCommandOptionValueUser name <$> v .: "value" + 7 -> + InteractionDataApplicationCommandOptionValueChannel name + <$> v + .: "value" + 8 -> + InteractionDataApplicationCommandOptionValueRole name <$> v .: "value" + 9 -> + InteractionDataApplicationCommandOptionValueMentionable name + <$> v + .: "value" + _ -> + fail + $ "unexpected interaction data application command option value type: " + ++ show t + ) data InteractionDataModal = InteractionDataModal { -- | The unique id of the component (up to 100 characters). - interactionDataModalCustomId :: T.Text, + interactionDataModalCustomId :: T.Text + , -- | Components from the modal. interactionDataModalComponents :: [ComponentTextInput] } deriving (Show, Read, Eq, Ord) instance FromJSON InteractionDataModal where - parseJSON = - withObject - "InteractionDataModal" - ( \v -> - InteractionDataModal <$> v .: "custom_id" - <*> ((v .: "components") >>= (join <$>) . mapM getTextInput) - ) - where - getTextInput :: Value -> Parser [ComponentTextInput] - getTextInput = withObject "InteractionDataModal.TextInput" $ \o -> do - t <- o .: "type" :: Parser Int - case t of - 1 -> o .: "components" - _ -> fail $ "expected action row type (1), got: " ++ show t + parseJSON = withObject + "InteractionDataModal" + (\v -> + InteractionDataModal + <$> v + .: "custom_id" + <*> ((v .: "components") >>= (join <$>) . mapM getTextInput) + ) + where + getTextInput :: Value -> Parser [ComponentTextInput] + getTextInput = withObject "InteractionDataModal.TextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 1 -> o .: "components" + _ -> fail $ "expected action row type (1), got: " ++ show t parseValue :: (FromJSON a) => Object -> Bool -> Parser (Either T.Text a) -parseValue o True = Left <$> o .: "value" +parseValue o True = Left <$> o .: "value" parseValue o False = Right <$> o .: "value" -- resolved data -- this should be formalised and integrated, instead of being @@ -485,42 +527,46 @@ parseValue o False = Right <$> o .: "value" -- -- https://discord.com/developers/docs/interactions/receiving-and-responding#interaction-object-resolved-data-structure data ResolvedData = ResolvedData - { resolvedDataUsers :: Maybe Value, - resolvedDataMembers :: Maybe Value, - resolvedDataRoles :: Maybe Value, - resolvedDataChannels :: Maybe Value, - resolvedDataMessages :: Maybe Value, - resolvedDataAttachments :: Maybe Value + { resolvedDataUsers :: Maybe Value + , resolvedDataMembers :: Maybe Value + , resolvedDataRoles :: Maybe Value + , resolvedDataChannels :: Maybe Value + , resolvedDataMessages :: Maybe Value + , resolvedDataAttachments :: Maybe Value } deriving (Show, Read, Eq, Ord) instance ToJSON ResolvedData where - toJSON ResolvedData {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("users", resolvedDataUsers), - ("members", resolvedDataMembers), - ("roles", resolvedDataRoles), - ("channels", resolvedDataChannels), - ("messages", resolvedDataMessages), - ("attachments", resolvedDataAttachments) - ] + toJSON ResolvedData {..} = object + [ (name, value) + | (name, Just value) <- + [ ("users" , resolvedDataUsers) + , ("members" , resolvedDataMembers) + , ("roles" , resolvedDataRoles) + , ("channels" , resolvedDataChannels) + , ("messages" , resolvedDataMessages) + , ("attachments", resolvedDataAttachments) ] + ] instance FromJSON ResolvedData where - parseJSON = - withObject - "ResolvedData" - ( \v -> - ResolvedData - <$> v .:? "users" - <*> v .:? "members" - <*> v .:? "roles" - <*> v .:? "channels" - <*> v .:? "messages" - <*> v .:? "attachments" - ) + parseJSON = withObject + "ResolvedData" + (\v -> + ResolvedData + <$> v + .:? "users" + <*> v + .:? "members" + <*> v + .:? "roles" + <*> v + .:? "channels" + <*> v + .:? "messages" + <*> v + .:? "attachments" + ) -- | The data to respond to an interaction with. Unless specified otherwise, you -- only have three seconds to reply to an interaction before a failure state is @@ -544,56 +590,73 @@ data InteractionResponse -- | A basic interaction response, sending back the given text. interactionResponseBasic :: T.Text -> InteractionResponse -interactionResponseBasic t = InteractionResponseChannelMessage (interactionResponseMessageBasic t) +interactionResponseBasic t = + InteractionResponseChannelMessage (interactionResponseMessageBasic t) instance ToJSON InteractionResponse where - toJSON InteractionResponsePong = object [("type", Number 1)] + toJSON InteractionResponsePong = object [("type", Number 1)] toJSON InteractionResponseDeferChannelMessage = object [("type", Number 5)] - toJSON InteractionResponseDeferUpdateMessage = object [("type", Number 6)] - toJSON (InteractionResponseChannelMessage ms) = object [("type", Number 4), ("data", toJSON ms)] - toJSON (InteractionResponseUpdateMessage ms) = object [("type", Number 7), ("data", toJSON ms)] - toJSON (InteractionResponseAutocompleteResult ms) = object [("type", Number 8), ("data", toJSON ms)] - toJSON (InteractionResponseModal ms) = object [("type", Number 9), ("data", toJSON ms)] + toJSON InteractionResponseDeferUpdateMessage = object [("type", Number 6)] + toJSON (InteractionResponseChannelMessage ms) = + object [("type", Number 4), ("data", toJSON ms)] + toJSON (InteractionResponseUpdateMessage ms) = + object [("type", Number 7), ("data", toJSON ms)] + toJSON (InteractionResponseAutocompleteResult ms) = + object [("type", Number 8), ("data", toJSON ms)] + toJSON (InteractionResponseModal ms) = + object [("type", Number 9), ("data", toJSON ms)] data InteractionResponseAutocomplete = InteractionResponseAutocompleteString [Choice T.Text] | InteractionResponseAutocompleteInteger [Choice Integer] | InteractionResponseAutocompleteNumber [Choice Scientific] deriving (Show, Read, Eq, Ord) instance ToJSON InteractionResponseAutocomplete where - toJSON (InteractionResponseAutocompleteString cs) = object [("choices", toJSON cs)] - toJSON (InteractionResponseAutocompleteInteger cs) = object [("choices", toJSON cs)] - toJSON (InteractionResponseAutocompleteNumber cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteString cs) = + object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteInteger cs) = + object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteNumber cs) = + object [("choices", toJSON cs)] -- | A cut down message structure. data InteractionResponseMessage = InteractionResponseMessage - { interactionResponseMessageTTS :: Maybe Bool, - interactionResponseMessageContent :: Maybe T.Text, - interactionResponseMessageEmbeds :: Maybe [CreateEmbed], - interactionResponseMessageAllowedMentions :: Maybe AllowedMentions, - interactionResponseMessageFlags :: Maybe InteractionResponseMessageFlags, - interactionResponseMessageComponents :: Maybe [ComponentActionRow], - interactionResponseMessageAttachments :: Maybe [Attachment] + { interactionResponseMessageTTS :: Maybe Bool + , interactionResponseMessageContent :: Maybe T.Text + , interactionResponseMessageEmbeds :: Maybe [CreateEmbed] + , interactionResponseMessageAllowedMentions :: Maybe AllowedMentions + , interactionResponseMessageFlags :: Maybe InteractionResponseMessageFlags + , interactionResponseMessageComponents :: Maybe [ComponentActionRow] + , interactionResponseMessageAttachments :: Maybe [Attachment] } deriving (Show, Read, Eq, Ord) -- | A basic interaction response, sending back the given text. This is -- effectively a helper function. interactionResponseMessageBasic :: T.Text -> InteractionResponseMessage -interactionResponseMessageBasic t = InteractionResponseMessage Nothing (Just t) Nothing Nothing Nothing Nothing Nothing +interactionResponseMessageBasic t = InteractionResponseMessage Nothing + (Just t) + Nothing + Nothing + Nothing + Nothing + Nothing instance ToJSON InteractionResponseMessage where - toJSON InteractionResponseMessage {..} = - object - [ (name, value) - | (name, Just value) <- - [ ("tts", toJSON <$> interactionResponseMessageTTS), - ("content", toJSON <$> interactionResponseMessageContent), - ("embeds", toJSON . (createEmbed <$>) <$> interactionResponseMessageEmbeds), - ("allowed_mentions", toJSON <$> interactionResponseMessageAllowedMentions), - ("flags", toJSON <$> interactionResponseMessageFlags), - ("components", toJSON <$> interactionResponseMessageComponents), - ("attachments", toJSON <$> interactionResponseMessageAttachments) - ] + toJSON InteractionResponseMessage {..} = object + [ (name, value) + | (name, Just value) <- + [ ("tts" , toJSON <$> interactionResponseMessageTTS) + , ("content", toJSON <$> interactionResponseMessageContent) + , ( "embeds" + , toJSON . (createEmbed <$>) <$> interactionResponseMessageEmbeds + ) + , ( "allowed_mentions" + , toJSON <$> interactionResponseMessageAllowedMentions + ) + , ("flags" , toJSON <$> interactionResponseMessageFlags) + , ("components" , toJSON <$> interactionResponseMessageComponents) + , ("attachments", toJSON <$> interactionResponseMessageAttachments) ] + ] -- | Types of flags to attach to the interaction message. -- @@ -608,23 +671,29 @@ newtype InteractionResponseMessageFlags = InteractionResponseMessageFlags [Inter instance Enum InteractionResponseMessageFlag where fromEnum InteractionResponseMessageFlagEphermeral = 1 `shift` 6 toEnum i - | i == 1 `shift` 6 = InteractionResponseMessageFlagEphermeral - | otherwise = error $ "could not find InteractionCallbackDataFlag `" ++ show i ++ "`" + | i == 1 `shift` 6 + = InteractionResponseMessageFlagEphermeral + | otherwise + = error $ "could not find InteractionCallbackDataFlag `" ++ show i ++ "`" instance ToJSON InteractionResponseMessageFlags where - toJSON (InteractionResponseMessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) + toJSON (InteractionResponseMessageFlags fs) = + Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) data InteractionResponseModalData = InteractionResponseModalData - { interactionResponseModalCustomId :: T.Text, - interactionResponseModalTitle :: T.Text, - interactionResponseModalComponents :: [ComponentTextInput] + { interactionResponseModalCustomId :: T.Text + , interactionResponseModalTitle :: T.Text + , interactionResponseModalComponents :: [ComponentTextInput] } deriving (Show, Read, Eq, Ord) instance ToJSON InteractionResponseModalData where - toJSON InteractionResponseModalData {..} = - object - [ ("custom_id", toJSON interactionResponseModalCustomId), - ("title", toJSON interactionResponseModalTitle), - ("components", toJSON $ map (\ti -> object [("type", Number 1), ("components", toJSON [ti])]) interactionResponseModalComponents) - ] + toJSON InteractionResponseModalData {..} = object + [ ("custom_id", toJSON interactionResponseModalCustomId) + , ("title" , toJSON interactionResponseModalTitle) + , ( "components" + , toJSON $ map + (\ti -> object [("type", Number 1), ("components", toJSON [ti])]) + interactionResponseModalComponents + ) + ] diff --git a/src/Discord/Internal/Types/Prelude.hs b/src/Discord/Internal/Types/Prelude.hs index 18fbb505..fa681fae 100644 --- a/src/Discord/Internal/Types/Prelude.hs +++ b/src/Discord/Internal/Types/Prelude.hs @@ -7,18 +7,21 @@ -- | Provides base types and utility functions needed for modules in Discord.Internal.Types module Discord.Internal.Types.Prelude where -import Data.Bits -import Data.Word - -import Data.Aeson.Types -import Data.Time.Clock -import qualified Data.Text as T -import Data.Time.Clock.POSIX - -import Data.Functor.Compose (Compose(Compose, getCompose)) -import Data.Bifunctor (first) -import Text.Read (readMaybe) -import Data.Data (Data (dataTypeOf), dataTypeConstrs, fromConstr) +import Data.Bits +import Data.Word + +import Data.Aeson.Types +import qualified Data.Text as T +import Data.Time.Clock +import Data.Time.Clock.POSIX + +import Data.Bifunctor ( first ) +import Data.Data ( Data(dataTypeOf) + , dataTypeConstrs + , fromConstr + ) +import Data.Functor.Compose ( Compose(Compose, getCompose) ) +import Text.Read ( readMaybe ) -- | Authorization token for the Discord API newtype Auth = Auth T.Text @@ -27,9 +30,10 @@ newtype Auth = Auth T.Text -- | Get the raw token formatted for use with the websocket gateway authToken :: Auth -> T.Text -authToken (Auth tok) = let token = T.strip tok - bot = if "Bot " `T.isPrefixOf` token then "" else "Bot " - in bot <> token +authToken (Auth tok) = + let token = T.strip tok + bot = if "Bot " `T.isPrefixOf` token then "" else "Bot " + in bot <> token -- | A unique integer identifier. Can be used to calculate the creation date of an entity. newtype Snowflake = Snowflake Word64 @@ -45,14 +49,12 @@ instance ToJSON Snowflake where toJSON (Snowflake snowflake) = String . T.pack $ show snowflake instance FromJSON Snowflake where - parseJSON = - withText - "Snowflake" - ( \snowflake -> - case readMaybe (T.unpack snowflake) of - Nothing -> fail "null snowflake" - (Just i) -> pure i - ) + parseJSON = withText + "Snowflake" + (\snowflake -> case readMaybe (T.unpack snowflake) of + Nothing -> fail "null snowflake" + (Just i) -> pure i + ) type ChannelId = Snowflake type StageId = Snowflake @@ -77,8 +79,8 @@ type Shard = (Int, Int) -- | Gets a creation date from a snowflake. snowflakeCreationDate :: Snowflake -> UTCTime -snowflakeCreationDate x = posixSecondsToUTCTime . realToFrac - $ 1420070400 + quot (shiftR x 22) 1000 +snowflakeCreationDate x = + posixSecondsToUTCTime . realToFrac $ 1420070400 + quot (shiftR x 22) 1000 -- | Default timestamp epochTime :: UTCTime diff --git a/src/Discord/Internal/Types/ScheduledEvents.hs b/src/Discord/Internal/Types/ScheduledEvents.hs index ca7cb333..3a3159ed 100644 --- a/src/Discord/Internal/Types/ScheduledEvents.hs +++ b/src/Discord/Internal/Types/ScheduledEvents.hs @@ -560,7 +560,10 @@ instance FromJSON ScheduledEventUser where "ScheduledEventUser" (\v -> ScheduledEventUser - <$> v .: "guild_scheduled_event_id" - <*> v .: "user" - <*> v .:? "member" + <$> v + .: "guild_scheduled_event_id" + <*> v + .: "user" + <*> v + .:? "member" ) diff --git a/src/Discord/Internal/Types/User.hs b/src/Discord/Internal/Types/User.hs index b0b52cd9..7b19256f 100644 --- a/src/Discord/Internal/Types/User.hs +++ b/src/Discord/Internal/Types/User.hs @@ -4,11 +4,11 @@ -- | Data structures pertaining to Discord User module Discord.Internal.Types.User where -import Data.Aeson -import Data.Text (Text) -import qualified Data.Text as T -import Discord.Internal.Types.Prelude -import Data.Time (UTCTime) +import Data.Aeson +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Time ( UTCTime ) +import Discord.Internal.Types.Prelude -- | Represents information about a user. data User = User @@ -29,126 +29,173 @@ data User = User , userPremiumType :: Maybe Integer -- ^ The user's premium type. , userPublicFlags :: Maybe Integer -- ^ The user's public flags. , userMember :: Maybe GuildMember -- ^ Some guild member info (message create/update) - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON User where parseJSON = withObject "User" $ \o -> - User <$> o .: "id" - <*> o .: "username" - <*> o .:? "discriminator" -- possibly not there in the case of webhooks - <*> o .:? "avatar" - <*> o .:? "bot" .!= False - <*> pure False -- webhook - <*> o .:? "system" - <*> o .:? "mfa_enabled" - <*> o .:? "banner" - <*> o .:? "accent_color" - <*> o .:? "locale" - <*> o .:? "verified" - <*> o .:? "email" - <*> o .:? "flags" - <*> o .:? "premium_type" - <*> o .:? "public_flags" - <*> o .:? "member" + User + <$> o + .: "id" + <*> o + .: "username" + <*> o + .:? "discriminator" -- possibly not there in the case of webhooks + <*> o + .:? "avatar" + <*> o + .:? "bot" + .!= False + <*> pure False -- webhook + <*> o + .:? "system" + <*> o + .:? "mfa_enabled" + <*> o + .:? "banner" + <*> o + .:? "accent_color" + <*> o + .:? "locale" + <*> o + .:? "verified" + <*> o + .:? "email" + <*> o + .:? "flags" + <*> o + .:? "premium_type" + <*> o + .:? "public_flags" + <*> o + .:? "member" instance ToJSON User where - toJSON User{..} = object [(name,value) | (name, Just value) <- - [ ("id", toJSON <$> pure userId) - , ("username", toJSON <$> pure userName) - , ("discriminator", toJSON <$> userDiscrim) - , ("avatar", toJSON <$> userAvatar) - , ("bot", toJSON <$> pure userIsBot) - , ("system", toJSON <$> userIsSystem) - , ("mfa_enabled", toJSON <$> userMfa) - , ("banner", toJSON <$> userBanner) - , ("accent_color", toJSON <$> userAccentColor) - , ("verified", toJSON <$> userVerified) - , ("email", toJSON <$> userEmail) - , ("flags", toJSON <$> userFlags) - , ("premium_type", toJSON <$> userPremiumType) - , ("public_flags", toJSON <$> userPublicFlags) - , ("member", toJSON <$> userPublicFlags) - ] ] + toJSON User {..} = object + [ (name, value) + | (name, Just value) <- + [ ("id" , toJSON <$> pure userId) + , ("username" , toJSON <$> pure userName) + , ("discriminator", toJSON <$> userDiscrim) + , ("avatar" , toJSON <$> userAvatar) + , ("bot" , toJSON <$> pure userIsBot) + , ("system" , toJSON <$> userIsSystem) + , ("mfa_enabled" , toJSON <$> userMfa) + , ("banner" , toJSON <$> userBanner) + , ("accent_color" , toJSON <$> userAccentColor) + , ("verified" , toJSON <$> userVerified) + , ("email" , toJSON <$> userEmail) + , ("flags" , toJSON <$> userFlags) + , ("premium_type" , toJSON <$> userPremiumType) + , ("public_flags" , toJSON <$> userPublicFlags) + , ("member" , toJSON <$> userPublicFlags) + ] + ] -- TODO: fully update webhook structure data Webhook = Webhook - { webhookId :: WebhookId - , webhookToken :: Maybe Text + { webhookId :: WebhookId + , webhookToken :: Maybe Text , webhookChannelId :: ChannelId - } deriving (Show, Read, Eq, Ord) + } + deriving (Show, Read, Eq, Ord) instance FromJSON Webhook where - parseJSON = withObject "Webhook" $ \o -> - Webhook <$> o .: "id" - <*> o .:? "token" - <*> o .: "channel_id" + parseJSON = withObject "Webhook" + $ \o -> Webhook <$> o .: "id" <*> o .:? "token" <*> o .: "channel_id" data ConnectionObject = ConnectionObject - { connectionObjectId :: Text - , connectionObjectName :: Text - , connectionObjectType :: Text - , connectionObjectRevoked :: Bool - , connectionObjectIntegrations :: [IntegrationId] - , connectionObjectVerified :: Bool - , connectionObjectFriendSyncOn :: Bool + { connectionObjectId :: Text + , connectionObjectName :: Text + , connectionObjectType :: Text + , connectionObjectRevoked :: Bool + , connectionObjectIntegrations :: [IntegrationId] + , connectionObjectVerified :: Bool + , connectionObjectFriendSyncOn :: Bool , connectionObjectShownInPresenceUpdates :: Bool - , connectionObjectVisibleToOthers :: Bool - } deriving (Show, Read, Eq, Ord) + , connectionObjectVisibleToOthers :: Bool + } + deriving (Show, Read, Eq, Ord) instance FromJSON ConnectionObject where parseJSON = withObject "ConnectionObject" $ \o -> do integrations <- o .: "integrations" - ConnectionObject <$> o .: "id" - <*> o .: "name" - <*> o .: "type" - <*> o .: "revoked" - <*> sequence (map (.: "id") integrations) - <*> o .: "verified" - <*> o .: "friend_sync" - <*> o .: "show_activity" - <*> ( (==) (1::Int) <$> o .: "visibility") + ConnectionObject + <$> o + .: "id" + <*> o + .: "name" + <*> o + .: "type" + <*> o + .: "revoked" + <*> sequence (map (.: "id") integrations) + <*> o + .: "verified" + <*> o + .: "friend_sync" + <*> o + .: "show_activity" + <*> ((==) (1 :: Int) <$> o .: "visibility") -- | Representation of a guild member. data GuildMember = GuildMember - { memberUser :: Maybe User -- ^ User object - not included in message_create or update - , memberNick :: Maybe T.Text -- ^ User's guild nickname - , memberAvatar :: Maybe T.Text -- ^ User's guild avatar hash - , memberRoles :: [RoleId] -- ^ Array of role ids - , memberJoinedAt :: UTCTime -- ^ When the user joined the guild - , memberPremiumSince :: Maybe UTCTime -- ^ When the user started boosting the guild - , memberDeaf :: Bool -- ^ Whether the user is deafened - , memberMute :: Bool -- ^ Whether the user is muted - , memberPending :: Bool -- ^ Whether the user has passed the guild's membership screening - , memberPermissions :: Maybe T.Text -- ^ total permissions of the member - , memberTimeoutEnd :: Maybe UTCTime -- ^ when the user's timeout will expire and they can communicate again - } deriving (Show, Read, Eq, Ord) + { memberUser :: Maybe User -- ^ User object - not included in message_create or update + , memberNick :: Maybe T.Text -- ^ User's guild nickname + , memberAvatar :: Maybe T.Text -- ^ User's guild avatar hash + , memberRoles :: [RoleId] -- ^ Array of role ids + , memberJoinedAt :: UTCTime -- ^ When the user joined the guild + , memberPremiumSince :: Maybe UTCTime -- ^ When the user started boosting the guild + , memberDeaf :: Bool -- ^ Whether the user is deafened + , memberMute :: Bool -- ^ Whether the user is muted + , memberPending :: Bool -- ^ Whether the user has passed the guild's membership screening + , memberPermissions :: Maybe T.Text -- ^ total permissions of the member + , memberTimeoutEnd :: Maybe UTCTime -- ^ when the user's timeout will expire and they can communicate again + } + deriving (Show, Read, Eq, Ord) instance FromJSON GuildMember where parseJSON = withObject "GuildMember" $ \o -> - GuildMember <$> o .:? "user" - <*> o .:? "nick" - <*> o .:? "avatar" - <*> o .: "roles" - <*> o .: "joined_at" - <*> o .:? "premium_since" - <*> o .: "deaf" - <*> o .: "mute" - <*> o .:? "pending" .!= False - <*> o .:? "permissions" - <*> o .:? "communication_disabled_until" + GuildMember + <$> o + .:? "user" + <*> o + .:? "nick" + <*> o + .:? "avatar" + <*> o + .: "roles" + <*> o + .: "joined_at" + <*> o + .:? "premium_since" + <*> o + .: "deaf" + <*> o + .: "mute" + <*> o + .:? "pending" + .!= False + <*> o + .:? "permissions" + <*> o + .:? "communication_disabled_until" instance ToJSON GuildMember where - toJSON GuildMember {..} = object [(name, value) | (name, Just value) <- - [ ("user", toJSON <$> memberUser) - , ("nick", toJSON <$> memberNick) - , ("avatar", toJSON <$> memberAvatar) - , ("roles", toJSON <$> pure memberRoles) - , ("joined_at", toJSON <$> pure memberJoinedAt) - , ("premium_since", toJSON <$> memberPremiumSince) - , ("deaf", toJSON <$> pure memberDeaf) - , ("mute", toJSON <$> pure memberMute) - , ("pending", toJSON <$> pure memberPending) - , ("permissions", toJSON <$> memberPermissions) - , ("communication_disabled_until", toJSON <$> memberTimeoutEnd) - ] ] + toJSON GuildMember {..} = object + [ (name, value) + | (name, Just value) <- + [ ("user" , toJSON <$> memberUser) + , ("nick" , toJSON <$> memberNick) + , ("avatar" , toJSON <$> memberAvatar) + , ("roles" , toJSON <$> pure memberRoles) + , ("joined_at" , toJSON <$> pure memberJoinedAt) + , ("premium_since" , toJSON <$> memberPremiumSince) + , ("deaf" , toJSON <$> pure memberDeaf) + , ("mute" , toJSON <$> pure memberMute) + , ("pending" , toJSON <$> pure memberPending) + , ("permissions" , toJSON <$> memberPermissions) + , ("communication_disabled_until", toJSON <$> memberTimeoutEnd) + ] + ] diff --git a/src/Discord/Requests.hs b/src/Discord/Requests.hs index eec48bf8..22e6f19c 100644 --- a/src/Discord/Requests.hs +++ b/src/Discord/Requests.hs @@ -10,12 +10,12 @@ module Discord.Requests , module Discord.Internal.Rest.Interactions ) where -import Discord.Internal.Rest.Channel -import Discord.Internal.Rest.Emoji -import Discord.Internal.Rest.Guild -import Discord.Internal.Rest.Invite -import Discord.Internal.Rest.User -import Discord.Internal.Rest.Voice -import Discord.Internal.Rest.Webhook -import Discord.Internal.Rest.ApplicationCommands -import Discord.Internal.Rest.Interactions +import Discord.Internal.Rest.ApplicationCommands +import Discord.Internal.Rest.Channel +import Discord.Internal.Rest.Emoji +import Discord.Internal.Rest.Guild +import Discord.Internal.Rest.Interactions +import Discord.Internal.Rest.Invite +import Discord.Internal.Rest.User +import Discord.Internal.Rest.Voice +import Discord.Internal.Rest.Webhook diff --git a/src/Discord/Types.hs b/src/Discord/Types.hs index c4c5da0b..def47968 100644 --- a/src/Discord/Types.hs +++ b/src/Discord/Types.hs @@ -3,13 +3,11 @@ module Discord.Types ( module Discord.Internal.Types ) where -import Discord.Internal.Types hiding - ( GatewaySendableInternal(..) - , GatewayReceivable(..) - , EventInternalParse(..) - , InternalDiscordEnum(..) - - , colorToInternal - , convertToRGB - , hexToRGB - ) +import Discord.Internal.Types hiding ( EventInternalParse(..) + , GatewayReceivable(..) + , GatewaySendableInternal(..) + , InternalDiscordEnum(..) + , colorToInternal + , convertToRGB + , hexToRGB + )