discord-haskell 1.8.8 → 1.8.9

raw patch · 11 files changed

+95/−58 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +16/−11
• changelog.md +7/−0
• discord-haskell.cabal +3/−3
• examples/ping-pong.hs +11/−14
• src/Discord/Internal/Gateway/EventLoop.hs +15/−7
• src/Discord/Internal/Rest/Channel.hs +14/−8
• src/Discord/Internal/Rest/Emoji.hs +2/−1
• src/Discord/Internal/Rest/Guild.hs +1/−1
• src/Discord/Internal/Rest/Prelude.hs +1/−1
• src/Discord/Internal/Rest/User.hs +1/−0
• src/Discord/Internal/Rest/Webhook.hs +24/−12

@@ -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 

@@ -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)

@@ -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 <https://discord.com/developers/docs/reference>.                      .@@ -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:

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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) =

@@ -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 //

@@ -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 =

@@ -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