diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# discord-haskell [![Build Status](https://travis-ci.com/aquarial/discord-haskell.png?branch=master)](https://travis-ci.com/aquarial/discord-haskell) [![Hackage version](http://img.shields.io/hackage/v/discord-haskell.svg?label=Hackage)](https://hackage.haskell.org/package/discord-haskell) +# discord-haskell [![Build Status](https://app.travis-ci.com/aquarial/discord-haskell.svg?branch=master)](https://app.travis-ci.com/github/aquarial/discord-haskell) [![Hackage version](http://img.shields.io/hackage/v/discord-haskell.svg?label=Hackage)](https://hackage.haskell.org/package/discord-haskell) Build that discord bot in Haskell! Also checkout the [calamity](https://github.com/nitros12/calamity) haskell discord library for a more advanced interface than `discord-haskell`. @@ -8,7 +8,7 @@ ```haskell {-# LANGUAGE OverloadedStrings #-} -- allows "string literals" to be Text -import Control.Monad (when) +import Control.Monad (when, void) import Data.Text (isPrefixOf, toLower, Text) import qualified Data.Text.IO as TIO @@ -27,20 +27,25 @@ eventHandler :: Event -> DiscordHandler () eventHandler event = case event of - MessageCreate m -> when (not (fromBot m) && isPing (messageText m)) $ do - _ <- restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") - threadDelay (4 * 10^6) - _ <- restCall (R.CreateMessage (messageChannel m) "Pong!") - pure () - _ -> pure () + MessageCreate m -> when (not (fromBot m) && isPing m) $ do + void $ restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") + threadDelay (2 * 10^6) + void $ restCall (R.CreateMessage (messageChannel m) "Pong!") + _ -> return () fromBot :: Message -> Bool -fromBot m = userIsBot (messageAuthor m) +fromBot = userIsBot . messageAuthor -isPing :: Text -> Bool -isPing = ("ping" `isPrefixOf`) . toLower +isPing :: Message -> Bool +isPing = ("ping" `isPrefixOf`) . toLower . messageText ``` +### Biggest TODOs + +- [ ] APIv9 +- [ ] rewrite eventloop [issue 70](https://github.com/aquarial/discord-haskell/issues/70) +- [ ] Event type includes roles and other cached info +- [ ] higher level bot interface? easier to add state and stuff ### Installing diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,13 @@ ## master + +## 1.8.9 + +Handle both aeson 1.0 and 2.0 [(breaking changes broke builds)](https://github.com/aquarial/discord-haskell/issues/77) + +Simplify [some examples](https://github.com/aquarial/discord-haskell/issues/71) + ## 1.8.8 Remove git artifacts from [examples/ping-pong.hs](https://github.com/aquarial/discord-haskell/issues/69) diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 1.8.8 +version: 1.8.9 description: Functions and data types to write discord bots. Official discord docs . . @@ -28,7 +28,7 @@ main-is: examples/ping-pong.hs default-language: Haskell2010 ghc-options: -Wall - -fno-warn-type-defaults + -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded build-depends: base , text @@ -37,7 +37,7 @@ library ghc-options: -Wall - -fno-warn-type-defaults + -fno-warn-type-defaults -fno-warn-unused-record-wildcards hs-source-dirs: src default-language: Haskell2010 -- extensions: diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs --- a/examples/ping-pong.hs +++ b/examples/ping-pong.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text -import Control.Monad (when, forM_) +import Control.Monad (when, forM_, void) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -27,7 +27,6 @@ , discordOnEvent = eventHandler , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" } - threadDelay (1 `div` 10 * 10^(6 :: Int)) TIO.putStrLn t -- If the start handler throws an exception, discord-haskell will gracefully shutdown @@ -50,20 +49,20 @@ forM_ partialGuilds $ \pg -> do Right guild <- restCall $ R.GetGuild (partialGuildId pg) Right chans <- restCall $ R.GetGuildChannels (guildId guild) - case filter isTextChannel chans of - (c:_) -> do _ <- restCall $ R.CreateMessage (channelId c) "Hello! I will reply to pings with pongs" - pure () - _ -> pure () + 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 - _ <- restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") - threadDelay (4 * 10^(6 :: Int)) + void $ restCall (R.CreateReaction (messageChannel m, messageId m) "eyes") + threadDelay (2 * 10^(6 :: Int)) -- A very simple message. - _ <- restCall (R.CreateMessage (messageChannel m) "Pong!") + void $ restCall (R.CreateMessage (messageChannel m) "Pong!") -- A more complex message. Text-to-speech, does not mention everyone nor -- the user, and uses Discord native replies. @@ -78,17 +77,15 @@ , R.messageDetailedReference = Just $ def { referenceMessageId = Just $ messageId m } } - _ <- restCall (R.CreateMessageDetailed (messageChannel m) opts) - - pure () - _ -> pure () + void $ restCall (R.CreateMessageDetailed (messageChannel m) opts) + _ -> return () isTextChannel :: Channel -> Bool isTextChannel (ChannelText {}) = True isTextChannel _ = False fromBot :: Message -> Bool -fromBot m = userIsBot (messageAuthor m) +fromBot = userIsBot . messageAuthor isPing :: Message -> Bool isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageText diff --git a/src/Discord/Internal/Gateway/EventLoop.hs b/src/Discord/Internal/Gateway/EventLoop.hs --- a/src/Discord/Internal/Gateway/EventLoop.hs +++ b/src/Discord/Internal/Gateway/EventLoop.hs @@ -64,6 +64,9 @@ Right m -> do writeChan events (Left (GatewayExceptionUnexpected m "Response to Identify must be Ready")) pure ConnClosed + Left (CloseRequest code _str) -> do writeChan log ("gateway - close " <> T.pack (show code)) + threadDelay (3 * (10^(6 :: Int))) + pure ConnStart Left ce -> do writeChan events (Left (GatewayExceptionConnection ce "Response to Identify")) pure ConnClosed @@ -71,6 +74,9 @@ writeChan events (Left (GatewayExceptionUnexpected m "Response to connecting must be hello")) pure ConnClosed + Left (CloseRequest code _str) -> do writeChan log ("gateway - close " <> T.pack (show code)) + threadDelay (3 * (10^(6 :: Int))) + pure ConnStart Left ce -> do writeChan events (Left (GatewayExceptionConnection ce "Response to connecting")) pure ConnClosed @@ -97,9 +103,12 @@ writeChan events (Left (GatewayExceptionUnexpected payload "Response to Resume must be Hello/Invalid Session")) pure ConnClosed + Left (CloseRequest code _str) -> do + writeChan log ("gateway - retrying from " <> T.pack (show code)) + threadDelay (3 * (10^(6 :: Int))) + pure (ConnReconnect (Auth tok) seshID seqID) Left e -> do - writeChan events (Left (GatewayExceptionConnection e - "Could not ConnReconnect")) + writeChan events (Left (GatewayExceptionConnection e "Could not ConnReconnect")) pure ConnClosed case next :: Either SomeException ConnLoopState of Left _ -> do t <- getRandomR (3,20) @@ -135,9 +144,6 @@ writeChan send (Heartbeat num) threadDelay (interval * 1000) -setSequence :: IORef Integer -> Integer -> IO () -setSequence key i = writeIORef key i - -- | What we need to start an event stream data ConnectionData = ConnData { connection :: Connection , connSessionID :: T.Text @@ -172,6 +178,8 @@ case eitherPayload :: Either ConnectionException GatewayReceivable of 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 -> ConnReconnect auth seshID <$> readIORef seqKey 1001 -> ConnReconnect auth seshID <$> readIORef seqKey 4000 -> ConnReconnect auth seshID <$> readIORef seqKey @@ -182,11 +190,11 @@ "Normal event loop close request")) pure ConnClosed Left _ -> ConnReconnect auth seshID <$> readIORef seqKey - Right (Dispatch event sq) -> do setSequence seqKey sq + Right (Dispatch event sq) -> do writeIORef seqKey sq writeChan eventChan (Right event) writeIORef userSends True loop - Right (HeartbeatRequest sq) -> do setSequence seqKey sq + Right (HeartbeatRequest sq) -> do writeIORef seqKey sq writeChan send (Heartbeat sq) loop Right (Reconnect) -> ConnReconnect auth seshID <$> readIORef seqKey diff --git a/src/Discord/Internal/Rest/Channel.hs b/src/Discord/Internal/Rest/Channel.hs --- a/src/Discord/Internal/Rest/Channel.hs +++ b/src/Discord/Internal/Rest/Channel.hs @@ -106,7 +106,7 @@ , messageDetailedFile :: Maybe (T.Text, B.ByteString) , messageDetailedAllowedMentions :: Maybe AllowedMentions , messageDetailedReference :: Maybe MessageReference - } + } deriving (Show, Eq, Ord) instance Default MessageDetailedOpts where def = MessageDetailedOpts { messageDetailedContent = "" @@ -125,7 +125,7 @@ , mentionUserIds :: [UserId] , mentionRoleIds :: [RoleId] , mentionRepliedUser :: Bool - } + } deriving (Show, Eq, Ord) instance Default AllowedMentions where def = AllowedMentions { mentionEveryone = False @@ -140,8 +140,10 @@ toJSON AllowedMentions{..} = object [ ("parse" .= [name :: T.Text | (name, True) <- [ ("everyone", mentionEveryone), - ("users", mentionUsers), - ("roles", mentionRoles) ] ]), + ("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) ] @@ -150,6 +152,7 @@ data ReactionTiming = BeforeReaction MessageId | AfterReaction MessageId | LatestReaction + deriving (Show, Eq, Ord) reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https reactionTimingToQuery t = case t of @@ -162,6 +165,7 @@ | BeforeMessage MessageId | AfterMessage MessageId | LatestMessages + deriving (Show, Eq, Ord) messageTimingToQuery :: MessageTiming -> R.Option 'R.Https messageTimingToQuery t = case t of @@ -175,7 +179,7 @@ , channelInviteOptsMaxUsages :: Maybe Integer , channelInviteOptsIsTemporary :: Maybe Bool , channelInviteOptsDontReuseSimilarInvite :: Maybe Bool - } + } deriving (Show, Eq, Ord) instance ToJSON ChannelInviteOpts where toJSON ChannelInviteOpts{..} = object [(name, val) | (name, Just val) <- @@ -193,7 +197,7 @@ , modifyChannelUserRateLimit :: Maybe Integer , modifyChannelPermissionOverwrites :: Maybe [Overwrite] , modifyChannelParentId :: Maybe ChannelId - } + } deriving (Show, Eq, Ord) instance ToJSON ModifyChannelOpts where toJSON ModifyChannelOpts{..} = object [(name, val) | (name, Just val) <- @@ -209,10 +213,12 @@ data ChannelPermissionsOpts = ChannelPermissionsOpts { channelPermissionsOptsAllow :: Integer , channelPermissionsOptsDeny :: Integer - , channelPermissionsOptsType :: ChannelPermissionsOptsType} + , channelPermissionsOptsType :: ChannelPermissionsOptsType + } deriving (Show, Eq, Ord) data ChannelPermissionsOptsType = ChannelPermissionsOptsUser | ChannelPermissionsOptsRole + deriving (Show, Eq, Ord) instance ToJSON ChannelPermissionsOptsType where toJSON t = case t of ChannelPermissionsOptsUser -> String "member" @@ -228,7 +234,7 @@ { groupDMAddRecipientUserToAdd :: UserId , groupDMAddRecipientUserToAddNickName :: T.Text , groupDMAddRecipientGDMJoinAccessToken :: T.Text - } + } deriving (Show, Eq, Ord) channelMajorRoute :: ChannelRequest a -> String channelMajorRoute c = case c of diff --git a/src/Discord/Internal/Rest/Emoji.hs b/src/Discord/Internal/Rest/Emoji.hs --- a/src/Discord/Internal/Rest/Emoji.hs +++ b/src/Discord/Internal/Rest/Emoji.hs @@ -45,7 +45,7 @@ data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts { modifyGuildEmojiName :: T.Text , modifyGuildEmojiRoles :: [RoleId] - } + } deriving (Show, Eq, Ord) instance ToJSON ModifyGuildEmojiOpts where toJSON (ModifyGuildEmojiOpts name roles) = @@ -53,6 +53,7 @@ data EmojiImageParsed = EmojiImageParsed T.Text + deriving (Show, Eq, Ord) parseEmojiImage :: B.ByteString -> Either T.Text EmojiImageParsed parseEmojiImage bs = diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs --- a/src/Discord/Internal/Rest/Guild.hs +++ b/src/Discord/Internal/Rest/Guild.hs @@ -287,7 +287,7 @@ data GuildMembersTiming = GuildMembersTiming { guildMembersTimingLimit :: Maybe Int , guildMembersTimingAfter :: Maybe UserId - } + } deriving (Show, Eq, Ord) guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) = diff --git a/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs --- a/src/Discord/Internal/Rest/Prelude.hs +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -29,7 +29,7 @@ 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.8.8)" + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.8.9)" -- Append to an URL infixl 5 // diff --git a/src/Discord/Internal/Rest/User.hs b/src/Discord/Internal/Rest/User.hs --- a/src/Discord/Internal/Rest/User.hs +++ b/src/Discord/Internal/Rest/User.hs @@ -54,6 +54,7 @@ -- | Formatted avatar data https://discord.com/developers/docs/resources/user#avatar-data data CurrentUserAvatar = CurrentUserAvatar T.Text + deriving (Show, Eq, Ord) parseCurrentUserAvatar :: B.ByteString -> Either T.Text CurrentUserAvatar parseCurrentUserAvatar bs = diff --git a/src/Discord/Internal/Rest/Webhook.hs b/src/Discord/Internal/Rest/Webhook.hs --- a/src/Discord/Internal/Rest/Webhook.hs +++ b/src/Discord/Internal/Rest/Webhook.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE InstanceSigs #-} @@ -13,7 +14,7 @@ , WebhookRequest(..) ) where -import Data.Aeson +import Data.Aeson import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -25,6 +26,17 @@ 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 +toKey :: T.Text -> T.Text +toKey = id +# endif + instance Request (WebhookRequest a) where majorRoute = webhookMajorRoute jsonRequest = webhookJsonRequest @@ -49,10 +61,10 @@ { modifyWebhookOptsName :: Maybe T.Text , modifyWebhookOptsAvatar :: Maybe T.Text , modifyWebhookOptsChannelId :: Maybe ChannelId - } + } deriving (Show, Eq, Ord) instance ToJSON ModifyWebhookOpts where - toJSON ModifyWebhookOpts{..} = object [(name, val) | (name, Just val) <- + toJSON ModifyWebhookOpts{..} = object [(toKey name, val) | (name, Just val) <- [("channel_id", toJSON <$> modifyWebhookOptsChannelId), ("name", toJSON <$> modifyWebhookOptsName), ("avatar", toJSON <$> modifyWebhookOptsAvatar) ] ] @@ -60,7 +72,7 @@ data CreateWebhookOpts = CreateWebhookOpts { createWebhookOptsName :: T.Text , createWebhookOptsAvatar :: Maybe T.Text - } + } deriving (Show, Eq, Ord) instance ToJSON CreateWebhookOpts where toJSON CreateWebhookOpts{..} = object [(name, val) | (name, Just val) <- @@ -70,24 +82,24 @@ data ExecuteWebhookWithTokenOpts = ExecuteWebhookWithTokenOpts { executeWebhookWithTokenOptsUsername :: Maybe T.Text , executeWebhookWithTokenOptsContent :: WebhookContent - } - deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord) data WebhookContent = WebhookContentText T.Text | WebhookContentFile T.Text B.ByteString | WebhookContentEmbeds [CreateEmbed] deriving (Show, Eq, Ord) -webhookContentJson :: WebhookContent -> [(T.Text, Value)] +webhookContentJson :: WebhookContent -> [(T.Text, Maybe Value)] webhookContentJson c = case c of - WebhookContentText t -> [("content", toJSON t)] + WebhookContentText t -> [("content", Just (toJSON t))] WebhookContentFile _ _ -> [] - WebhookContentEmbeds e -> [("embeds", toJSON (createEmbed <$> e))] + WebhookContentEmbeds e -> [("embeds", Just (toJSON (createEmbed <$> e)))] instance ToJSON ExecuteWebhookWithTokenOpts where - toJSON ExecuteWebhookWithTokenOpts{..} = object $ [(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