discord-haskell 1.15.6 → 1.16.0

raw patch · 21 files changed

+224/−137 lines, 21 filesdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• changelog.md +12/−1
• discord-haskell.cabal +4/−2
• examples/interaction-commands.hs +3/−7
• examples/ping-pong.hs +2/−4
• src/Discord.hs +14/−11
• src/Discord/Internal/Gateway.hs +3/−2
• src/Discord/Internal/Gateway/Cache.hs +25/−37
• src/Discord/Internal/Rest/ApplicationInfo.hs +38/−0
• src/Discord/Internal/Rest/Emoji.hs +5/−6
• src/Discord/Internal/Rest/User.hs +1/−2
• src/Discord/Internal/Rest/Webhook.hs +2/−1
• src/Discord/Internal/Types.hs +2/−0
• src/Discord/Internal/Types/ApplicationInfo.hs +23/−0
• src/Discord/Internal/Types/Channel.hs +9/−9
• src/Discord/Internal/Types/Events.hs +15/−5
• src/Discord/Internal/Types/Gateway.hs +4/−7
• src/Discord/Internal/Types/Guild.hs +41/−10
• src/Discord/Internal/Types/Interactions.hs +1/−0
• src/Discord/Internal/Types/Prelude.hs +13/−29
• src/Discord/Internal/Types/RolePermissions.hs +5/−4
• src/Discord/Requests.hs +2/−0

@@ -4,9 +4,20 @@  The Discord API constantly changes. This library issues updates when we implement new features added to the API or remove outdated functionalities. In order to interact with the Discord API safely and predictably, please update the library whenever there is a new version released. -## Unreleased +## Unreleased  -++## 1.16.0++- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/187) Switched StatusOpts to a list of activities++- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/188) Dropped support for Aeson < 2.0.0 (see [here for migration guid](https://github.com/haskell/aeson/issues/881) and [here for why](https://frasertweedale.github.io/blog-fp/posts/2021-10-12-aeson-hash-flooding-protection.html))++- [aquarial](https://github.com/discord-haskell/discord-haskell/pull/190) Populate cache before onStart handler. Cache includes more app info++- [aquarial](https://github.com/discord-haskell/discord-haskell/pull/194) Export `ModalData` ADT internals+  ## 1.15.6 

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                discord-haskell-version:             1.15.6+version:             1.16.0 description:         Functions and data types to write discord bots.                      Official discord docs <https://discord.com/developers/docs/reference>.                      .@@ -140,6 +140,7 @@     , Discord.Internal.Rest.Voice     , Discord.Internal.Rest.Webhook     , Discord.Internal.Rest.ApplicationCommands+    , Discord.Internal.Rest.ApplicationInfo     , Discord.Internal.Rest.Interactions     , Discord.Internal.Rest.ScheduledEvents     , Discord.Internal.Types@@ -151,6 +152,7 @@     , Discord.Internal.Types.User     , Discord.Internal.Types.Embed     , Discord.Internal.Types.ApplicationCommands+    , Discord.Internal.Types.ApplicationInfo     , Discord.Internal.Types.Interactions     , Discord.Internal.Types.Components     , Discord.Internal.Types.Color@@ -161,7 +163,7 @@   -- https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/libraries/version-history   -- below also sets the GHC version effectively. set to == 8.10.*, == 9.0.*., == 9.2.*, == 9.4.*, == 9.6.*     base == 4.14.* || == 4.15.* || == 4.16.* || == 4.17.* || == 4.18.*,-    aeson >= 1.5 && < 1.6 || >= 2.0 && < 2.3,+    aeson >= 2.0 && < 2.3,     async >=2.2 && <2.3,     bytestring >=0.10 && <0.13,     base64-bytestring >=1.1 && <1.3,

@@ -54,15 +54,11 @@ --     Use place to execute commands you know you want to complete startHandler :: GuildId -> DiscordHandler () startHandler testserverid = do-  let activity =-        def-          { activityName = "ping-pong",-            activityType = ActivityTypeGame-          }+  let activity = mkActivity "interaction-commands" ActivityTypeGame   let opts =         UpdateStatusOpts           { updateStatusOptsSince = Nothing,-            updateStatusOptsGame = Just activity,+            updateStatusOptsActivities = [activity],             updateStatusOptsNewStatus = UpdateStatusOnline,             updateStatusOptsAFK = False           }@@ -394,7 +390,7 @@     void       ( do           exampleImage <- liftIO getImage-          aid <- readCache <&> cacheApplication <&> partialApplicationID+          aid <- readCache <&> cacheApplication <&> fullApplicationID           _ <- restCall (R.CreateInteractionResponse interactionId interactionToken InteractionResponseDeferChannelMessage)           restCall             ( R.CreateFollowupInteractionMessage

@@ -42,11 +42,9 @@ startHandler testserverid = do   liftIO $ putStrLn "Started ping-pong bot" -  let activity = def { activityName = "ping-pong"-                     , activityType = ActivityTypeGame-                     }+  let activity = (mkActivity "ping-pong" ActivityTypeStreaming) { activityUrl = Just "https://www.youtube.com/watch?v=dQw4w9WgXcQ", activityState = Just "rolling down a hill" }   let opts = UpdateStatusOpts { updateStatusOptsSince = Nothing-                              , updateStatusOptsGame = Just activity+                              , updateStatusOptsActivities = [activity]                               , updateStatusOptsNewStatus = UpdateStatusOnline                               , updateStatusOptsAFK = False                               }

@@ -42,6 +42,7 @@ import Discord.Internal.Rest import Discord.Internal.Rest.User (UserRequest(GetCurrentUser)) import Discord.Internal.Gateway+import qualified Discord.Requests as R  -- | A `ReaderT` wrapper around `DiscordHandle` and `IO`. Most functions act in -- this monad@@ -116,18 +117,24 @@ -- | Runs the main loop  runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text runDiscordLoop handle opts = do-  resp <- liftIO $ writeRestCall (discordHandleRestChan handle) GetCurrentUser+  resp <- startupRestCalls   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 (RestCallInternalNoParse e _) -> libError ("Couldn't parse initial bot info - " <> T.pack e)+    Right (user, app) -> do initializeCache user app (discordHandleCache handle)+                            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+   startupRestCalls :: IO (Either RestCallInternalException (User, FullApplication))+   startupRestCalls = do eUser <- writeRestCall (discordHandleRestChan handle) R.GetCurrentUser+                         eApp <- writeRestCall (discordHandleRestChan handle) R.GetCurrentApplication+                         pure $ (,) <$> eUser <*> eApp+    libError :: T.Text -> IO T.Text    libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg @@ -188,11 +195,7 @@ readCache :: DiscordHandler Cache readCache = do   h <- ask-  merr <- readMVar (cacheHandleCache (discordHandleCache h))-  case merr of-    Left (c, _) -> pure c-    Right c -> pure c-+  readMVar (cacheHandleCache (discordHandleCache h))  -- | Stop all the background threads stopDiscord :: DiscordHandler ()

@@ -7,6 +7,7 @@   , CacheHandle(..)   , GatewayException(..)   , Cache(..)+  , initializeCache   , startCacheThread   , startGatewayThread   , module Discord.Internal.Types@@ -21,13 +22,13 @@  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 (cacheLoop, Cache(..), CacheHandle(..), initializeCache)  -- | Starts a thread for the cache startCacheThread :: Bool -> Chan T.Text -> IO (CacheHandle, ThreadId) startCacheThread isEnabled log = do   events <- newChan :: IO (Chan (Either GatewayException EventInternalParse))-  cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache))+  cache <- newEmptyMVar :: IO (MVar Cache)   let cacheHandle = CacheHandle events cache   tid <- forkIO $ cacheLoop isEnabled cacheHandle log   pure (cacheHandle, tid)

@@ -5,7 +5,7 @@ module Discord.Internal.Gateway.Cache where  import Prelude hiding (log)-import Control.Monad (forever, join)+import Control.Monad (forever, join, when) import Control.Concurrent.MVar import Control.Concurrent.Chan import Data.Foldable (foldl')@@ -15,50 +15,38 @@ import Discord.Internal.Types import Discord.Internal.Gateway.EventLoop +-- |  Cached data from gateway. Set RunDiscordOpts.discordEnableCache=true to enable all the fields data Cache = Cache-     { cacheCurrentUser :: !User-     , cacheDMChannels :: !(M.Map ChannelId Channel)-     , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData)))-     , cacheChannels :: !(M.Map ChannelId Channel)-     , cacheApplication :: !PartialApplication+     { cacheCurrentUser :: !User -- ^ Filled before onStart handler+     , cacheDMChannels :: !(M.Map ChannelId Channel) -- ^ Filled over time+     , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData))) -- ^ Filled over time+     , cacheChannels :: !(M.Map ChannelId Channel) -- ^ Filled over time+     , cacheApplication :: !FullApplication -- ^ Filled before onStart handler      } deriving (Show) +-- | Internal handle for cacheLoop to manage the cache data CacheHandle = CacheHandle-  { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse)-  , cacheHandleCache  :: MVar (Either (Cache, GatewayException) Cache)+  { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse) -- ^ Read gateway events+  , cacheHandleCache  :: MVar Cache -- ^ Current cache.   } -cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO ()-cacheLoop isEnabled cacheHandle log = do-      ready <- readChan eventChan-      case ready of-        Right (InternalReady _ user _ _ _ _ pApp) -> do-          putMVar cache (Right (Cache user M.empty 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+-- | Internally used to setup the first cache+initializeCache :: User -> FullApplication -> CacheHandle -> IO ()+initializeCache user app cacheHandle = putMVar (cacheHandleCache cacheHandle) (Cache user M.empty M.empty M.empty app) -  loop :: IO ()-  loop = forever $ do-    eventOrExcept <- readChan eventChan-    if not isEnabled-      then return ()-      else do-        minfo <- takeMVar cache-        case minfo of-          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+-- | IO loop to update cache on each gateway event+cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO ()+cacheLoop isEnabled cacheHandle _log = when isEnabled $ forever $ do+    eventOrExcept <- readChan (cacheHandleEvents cacheHandle)+    case eventOrExcept of+      Left _ -> pure ()+      Right event -> modifyMVar_ (cacheHandleCache cacheHandle) $! pure . adjustCache event -adjustCache :: Cache -> EventInternalParse -> Cache-adjustCache minfo event = case event of-  InternalReady _ _ gus _ _ _ pa -> minfo { cacheApplication = pa, cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) }+-- | Apply gateway event to cache+adjustCache :: EventInternalParse -> Cache -> Cache+adjustCache event minfo = case event of+  -- note: ready only sends a partial app. we could update the info stored in the full app+  InternalReady _ _ gus _ _ _ _partialApp -> minfo { cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) }    InternalGuildCreate guild guildData ->     let newChans = guildCreateChannels guildData

@@ -0,0 +1,38 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides actions for Channel API interactions+module Discord.Internal.Rest.ApplicationInfo+  ( FullApplicationRequest(..)+  ) where++import Network.HTTP.Req ((/:))+import qualified Network.HTTP.Req as R++import Discord.Internal.Rest.Prelude+import Discord.Internal.Types++instance Request (FullApplicationRequest a) where+  majorRoute =  applicationMajorRoute+  jsonRequest = applicationJsonRequest+++-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API>+data FullApplicationRequest a where+  -- | Get the full application for the current user+  GetCurrentApplication :: FullApplicationRequest FullApplication++applicationMajorRoute :: FullApplicationRequest a -> String+applicationMajorRoute c = case c of+  (GetCurrentApplication) ->     "application "++applications :: R.Url 'R.Https+applications = baseUrl /: "applications"++applicationJsonRequest :: FullApplicationRequest r -> JsonRequest+applicationJsonRequest c = case c of+  (GetCurrentApplication) -> Get (applications /: "@me") mempty

@@ -20,7 +20,6 @@ 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 ((/:), (/~))@@ -65,7 +64,7 @@ parseEmojiImage :: B.ByteString -> Either T.Text (Base64Image Emoji) parseEmojiImage bs   | B.length bs > 256000        = Left "Cannot create emoji - File is larger than 256kb"-  | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs)))+  | Just mime <- getMimeType bs = Right (Base64Image mime (B64.encode bs))   | otherwise                   = Left "Unsupported image format provided"  emojiMajorRoute :: EmojiRequest a -> String@@ -112,13 +111,13 @@ parseStickerImage :: B.ByteString -> Either T.Text (Base64Image Sticker) parseStickerImage bs   | B.length bs > 512000-  = Left "Cannot create sticker - File is larger than 512kb"+      = Left "Cannot create sticker - File is larger than 512kb"   | Just "image/png" <- getMimeType bs-  = Right (Base64Image "image/png" (TE.decodeUtf8 (B64.encode bs)))+      = Right (Base64Image "image/png" (B64.encode bs))   | not (B.null bs) && B.head bs == 0x7b -- '{'-  = Right (Base64Image "application/json" (TE.decodeUtf8 (B64.encode bs)))+      = Right (Base64Image "application/json" (B64.encode bs))   | otherwise-  = Left "Unsupported image format provided"+      = Left "Unsupported image format provided"  -- | Options for `CreateGuildSticker` data CreateGuildStickerOpts = CreateGuildStickerOpts

@@ -15,7 +15,6 @@ 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.Base64 as B64 @@ -58,7 +57,7 @@ -- This function accepts all file types accepted by 'getMimeType'. parseAvatarImage :: B.ByteString -> Either T.Text (Base64Image User) parseAvatarImage bs-  | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs)))+  | Just mime <- getMimeType bs = Right (Base64Image mime (B64.encode bs))   | otherwise                   = Left "Unsupported image format provided"  userMajorRoute :: UserRequest a -> String

@@ -13,6 +13,7 @@   ) where  import           Data.Aeson+import qualified Data.Aeson.Key as Key import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -124,7 +125,7 @@                     | WebhookContentEmbeds [CreateEmbed]   deriving (Show, Read, Eq, Ord) -webhookContentJson :: WebhookContent -> [(AesonKey, Value)]+webhookContentJson :: WebhookContent -> [(Key.Key, Value)] webhookContentJson c = case c of                       WebhookContentText t -> [("content", toJSON t)]                       WebhookContentFile _ _  -> []

@@ -1,6 +1,7 @@ -- | 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.ApplicationInfo,     module Discord.Internal.Types.Channel,     module Discord.Internal.Types.Color,     module Discord.Internal.Types.Events,@@ -19,6 +20,7 @@  import Data.Aeson (Object, ToJSON (toJSON)) import Data.Time.Clock (UTCTime (..))+import Discord.Internal.Types.ApplicationInfo import Discord.Internal.Types.Channel import Discord.Internal.Types.Color import Discord.Internal.Types.Components

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Data structures pertaining to Discord User+module Discord.Internal.Types.ApplicationInfo where++import Data.Aeson+import qualified Data.Text as T+import Discord.Internal.Types.Prelude++-- | Structure containing partial information about an Application+data FullApplication = FullApplication+  { fullApplicationID :: ApplicationId+  , fullApplicationName :: T.Text+  , fullApplicationFlags :: Int+  } deriving (Show, Eq, Read)++instance FromJSON FullApplication where+  parseJSON = withObject "FullApplication" $ \o ->+    FullApplication <$> o .: "id"+                    <*> o .: "name"+                    <*> o .: "flags"+

@@ -170,7 +170,7 @@     case type' of       0 ->         ChannelText  <$> o .:  "id"-                     <*> o .:? "guild_id" .!= 0+                     <*> o .:  "guild_id"                      <*> o .:  "name"                      <*> o .:  "position"                      <*> o .:  "permission_overwrites"@@ -185,7 +185,7 @@                              <*> o .:? "last_message_id"       2 ->         ChannelVoice <$> o .:  "id"-                     <*> o .:? "guild_id" .!= 0+                     <*> o .:  "guild_id"                      <*> o .:  "name"                      <*> o .:  "position"                      <*> o .:  "permission_overwrites"@@ -199,13 +199,13 @@                        <*> o .:? "last_message_id"       4 ->         ChannelGuildCategory <$> o .: "id"-                             <*> o .:? "guild_id" .!= 0+                             <*> o .:  "guild_id"                              <*> o .:  "name"                              <*> o .:  "position"                              <*> o .:  "permission_overwrites"       5 ->         ChannelNews <$> o .:  "id"-                    <*> o .:? "guild_id" .!= 0+                    <*> o .:  "guild_id"                     <*> o .:  "name"                     <*> o .:  "position"                     <*> o .:  "permission_overwrites"@@ -215,14 +215,14 @@                     <*> o .:? "parent_id"       6 ->         ChannelStorePage <$> o .:  "id"-                         <*> o .:? "guild_id" .!= 0+                         <*> o .:  "guild_id"                          <*> o .:  "name"                          <*> o .:  "position"                          <*> o .:? "nsfw" .!= False                          <*> o .:  "permission_overwrites"                          <*> o .:? "parent_id"       10 -> ChannelNewsThread <$> o.: "id"-                              <*> o .:? "guild_id" .!= 0+                              <*> o .:  "guild_id"                               <*> o .:? "name"                               <*> o .:? "rate_limit_per_user"                               <*> o .:? "last_message_id"@@ -230,7 +230,7 @@                               <*> o .:? "thread_metadata"                               <*> o .:? "member"       11 -> ChannelPublicThread <$> o.: "id"-                                <*> o .:? "guild_id" .!= 0+                                <*> o .:  "guild_id"                                 <*> o .:? "name"                                 <*> o .:? "rate_limit_per_user"                                 <*> o .:? "last_message_id"@@ -238,7 +238,7 @@                                 <*> o .:? "thread_metadata"                                 <*> o .:? "member"       12 -> ChannelPrivateThread <$> o.: "id"-                                 <*> o .:? "guild_id" .!= 0+                                 <*> o .:  "guild_id"                                  <*> o .:? "name"                                  <*> o .:? "rate_limit_per_user"                                  <*> o .:? "last_message_id"@@ -247,7 +247,7 @@                                  <*> o .:? "member"       13 ->         ChannelStage <$> o .:  "id"-                     <*> o .:? "guild_id" .!= 0+                     <*> o .:  "guild_id"                      <*> o .:  "id"                      <*> o .:? "topic" .!= ""       _ -> ChannelUnknownType <$> o .:  "id"

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Data structures pertaining to gateway dispatch 'Event's module Discord.Internal.Types.Events where@@ -12,6 +13,7 @@  import Data.Aeson import Data.Aeson.Types+import qualified Data.Aeson.KeyMap as KM import qualified Data.Text as T  import Discord.Internal.Types.Prelude@@ -174,17 +176,25 @@   , guildCreateScheduledEvents :: ![ScheduledEvent]   } deriving (Show, Eq, Read) -instance FromJSON GuildCreateData where-  parseJSON = withObject "GuildCreateData" $ \o ->+parseGuildCreate :: Object -> Parser EventInternalParse+parseGuildCreate o = do+  guild :: Guild <- reparse o+  let gid = guildId guild+  channelValues :: [Object] <- o .: "channels"+  threadValues :: [Object] <- o .: "threads"+  let wellFormedChannels = fmap (Object . KM.insert "guild_id" (toJSON gid)) channelValues+      wellFormedThreads = fmap (Object . KM.insert "guild_id" (toJSON gid)) threadValues+  guildCreateData <-     GuildCreateData <$> o .:  "joined_at"                     <*> o .:  "large"                     <*> o .:? "unavailable"                     <*> o .:  "member_count"                     <*> o .:  "members"-                    <*> o .:  "channels"-                    <*> o .:  "threads"+                    <*> traverse parseJSON wellFormedChannels+                    <*> traverse parseJSON wellFormedThreads                     <*> o .:  "presences"                     <*> o .:  "guild_scheduled_events"+  pure $ InternalGuildCreate guild guildCreateData  -- | Structure containing information about a reaction data ReactionInfo = ReactionInfo@@ -275,7 +285,7 @@                                       stamp <- o .:? "last_pin_timestamp"                                       let utc = stamp >>= parseISO8601                                       pure (InternalChannelPinsUpdate id utc)-    "GUILD_CREATE"              -> InternalGuildCreate <$> reparse o <*> reparse o+    "GUILD_CREATE"              -> parseGuildCreate o     "GUILD_UPDATE"              -> InternalGuildUpdate               <$> reparse o     "GUILD_DELETE"              -> InternalGuildDelete               <$> reparse o     "GUILD_BAN_ADD"             -> InternalGuildBanAdd    <$> o .: "guild_id" <*> o .: "user"

@@ -129,9 +129,10 @@   deriving (Show, Read, Eq, Ord)  -- | Options for `UpdateStatus`+-- Presence Update - https://discord.com/developers/docs/topics/gateway-events#update-presence data UpdateStatusOpts = UpdateStatusOpts                       { updateStatusOptsSince :: Maybe UTCTime-                      , updateStatusOptsGame :: Maybe Activity+                      , updateStatusOptsActivities :: [Activity]                       , updateStatusOptsNewStatus :: UpdateStatusType                       , updateStatusOptsAFK :: Bool                       }@@ -214,17 +215,13 @@     ]  instance ToJSON GatewaySendable where-  toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [+  toJSON (UpdateStatus (UpdateStatusOpts since activities 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-                              ])+      , "activities" .= activities       ]     ]   toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) =

@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}  -- | Types relating to Discord Guilds (servers) module Discord.Internal.Types.Guild where@@ -7,16 +9,18 @@ import Data.Time.Clock  import Data.Aeson+import Data.Aeson.Types (Parser) import qualified Data.Text as T import Data.Data (Data)-import Data.Default (Default(..))+import Data.List  import Discord.Internal.Types.Prelude import Discord.Internal.Types.Color (DiscordColor) import Discord.Internal.Types.User (User) import Discord.Internal.Types.Emoji (Emoji, StickerItem)-import Data.List +import qualified Data.Aeson.KeyMap as KM+ -- | Guilds in Discord represent a collection of users and channels into an isolated --   "Server" --@@ -121,24 +125,40 @@ data PresenceInfo = PresenceInfo   { presenceUserId     :: UserId   -- , presenceRoles   :: [RoleId]-  , presenceActivities :: Maybe [Activity]+  -- | Activities and the names of their buttons. The buttons field of Activity+  -- will be blank, as the additional maybe field will have the button names it+  -- would contain.+  , presenceActivities :: Maybe [(Activity, Maybe [T.Text])]   , presenceGuildId    :: Maybe GuildId-  , presenceStatus     :: T.Text+  , presenceStatus     :: Maybe T.Text   } deriving (Show, Read, Eq, Ord)  instance FromJSON PresenceInfo where   parseJSON = withObject "PresenceInfo" $ \o ->     PresenceInfo <$> (o .: "user" >>= (.: "id"))-                 <*> o .:  "activities"+                 <*> (o .:? "activities" >>= parseActivities)                  <*> o .:? "guild_id"-                 <*> o .:  "status"+                 <*> o .:? "status"+    where+    parseActivities :: Maybe [Value] -> Parser (Maybe [(Activity, Maybe [T.Text])])+    parseActivities = \case+      Nothing -> pure Nothing+      Just vs -> Just <$> mapM parseIncomingActivity vs+    parseIncomingActivity :: Value -> Parser (Activity, Maybe [T.Text])+    parseIncomingActivity = withObject "PI Activity w/ BtnNames" $ \o -> do+      let o' = KM.delete "buttons" o+      act <- parseJSON (Object o')+      buttonNames <- o .:? "buttons"+      pure (act, buttonNames)  -- | Object for a single activity ----- https://discord.com/developers/docs/topics/gateway#activity-object+-- https://discord.com/developers/docs/topics/gateway-events#activity-object -- -- When setting a bot's activity, only the name, url, and type are sent - and -- it seems that not many types are permitted either.+--+-- Only youtube and twitch urls will work. data Activity =   Activity     { activityName :: T.Text -- ^ Name of activity@@ -155,12 +175,15 @@     -- 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+    , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence. When received, always Nothing!     }   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+-- | The quick and easy way to make an activity for a discord bot. +--+-- To set the `activityState` or `activityUrl`, please use record field syntax.+mkActivity :: T.Text -> ActivityType -> Activity+mkActivity name typ = Activity name typ Nothing (-1) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing  instance FromJSON Activity where   parseJSON = withObject "Activity" $ \o -> do@@ -179,6 +202,14 @@              <*> o .:? "instance"              <*> o .:? "flags"              <*> o .:? "buttons"++instance ToJSON Activity where+  toJSON Activity {..} = objectFromMaybes+    [ "name" .== activityName+    , "state" .=? activityState+    , "type" .== fromDiscordType activityType+    , if activityType == ActivityTypeStreaming then "url" .=? activityUrl else Nothing+    ]  data ActivityTimestamps = ActivityTimestamps   { activityTimestampsStart :: Maybe Integer -- ^ unix time in milliseconds

@@ -18,6 +18,7 @@     InteractionToken,     ResolvedData (..),     MemberOrUser (..),+    ModalData (..),     InteractionResponse (..),     interactionResponseBasic,     InteractionResponseAutocomplete (..),

@@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE RankNTypes  #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}  -- | Provides base types and utility functions needed for modules in Discord.Internal.Types@@ -49,7 +48,6 @@    , (.==)   , (.=?)-  , AesonKey   , objectFromMaybes    , ChannelTypeOption (..)@@ -71,10 +69,8 @@  import qualified Data.ByteString as B import qualified Data.Text as T--#if MIN_VERSION_aeson(2, 0, 0) import qualified Data.Aeson.Key as Key-#endif+import qualified Data.Text.Encoding as T.E  -- | Authorization token for the Discord API newtype Auth = Auth T.Text@@ -89,7 +85,7 @@  -- | A unique integer identifier. Can be used to calculate the creation date of an entity. newtype Snowflake = Snowflake { unSnowflake :: Word64 }-  deriving (Ord, Eq, Num, Integral, Enum, Real, Bits)+  deriving (Ord, Eq)  instance Show Snowflake where   show (Snowflake a) = show a@@ -114,7 +110,7 @@   toUrlPiece = T.pack . show  newtype RolePermissions = RolePermissions { getRolePermissions :: Integer } -  deriving (Eq, Ord, Num, Bits, Enum, Real, Integral)+  deriving (Eq, Ord, Bits)  instance Read RolePermissions where   readsPrec p = fmap (first RolePermissions) . readsPrec p@@ -134,7 +130,7 @@   show = show . getRolePermissions  newtype DiscordId a = DiscordId { unId :: Snowflake }-  deriving (Ord, Eq, Num, Integral, Enum, Real, Bits)+  deriving (Ord, Eq)  instance Show (DiscordId a) where   show = show . unId@@ -228,7 +224,7 @@  -- | Gets a creation date from a snowflake. snowflakeCreationDate :: Snowflake -> UTCTime-snowflakeCreationDate x = posixSecondsToUTCTime . realToFrac+snowflakeCreationDate (Snowflake x) = posixSecondsToUTCTime . realToFrac   $ 1420070400 + quot (shiftR x 22) 1000  -- | Default timestamp@@ -272,22 +268,10 @@         | fromIntegral (round i) == i = Just $ round i         | otherwise = Nothing --- Aeson 2.0 uses KeyMaps with a defined Key type for its objects. Aeson up to--- 1.5 uses HashMaps with Text for the key. Both types have an IsString instance.--- To keep our version bounds as loose as possible while the Haskell ecosystem--- (and thus our users) switch over to Aeson 2.0, we use some CPP to define a--- AesonKey as an alias.-#if MIN_VERSION_aeson(2, 0, 0)-type AesonKey = Key.Key-#else-type AesonKey = T.Text-#endif---(.==) :: ToJSON a => AesonKey -> a -> Maybe Pair+(.==) :: ToJSON a => Key.Key -> a -> Maybe Pair k .== v = Just (k .= v) -(.=?) :: ToJSON a => AesonKey -> Maybe a -> Maybe Pair+(.=?) :: ToJSON a => Key.Key -> Maybe a -> Maybe Pair k .=? (Just v) = Just (k .= v) _ .=? Nothing = Nothing @@ -301,7 +285,7 @@ -- -- Public creation of this datatype should be done using the relevant smart -- constructors for Emoji, Sticker, or Avatar.-data Base64Image a = Base64Image T.Text T.Text+data Base64Image a = Base64Image { mimeType :: T.Text, base64Data :: B.ByteString }   deriving (Show, Read, Eq, Ord)  -- | The ToJSON instance for Base64Image creates a string representation of the@@ -309,7 +293,7 @@ -- -- The format is: @data:%MIME%;base64,%DATA%@. instance ToJSON (Base64Image a) where-  toJSON (Base64Image mime im) = String $ "data:" <> mime <> ";base64," <> im+  toJSON (Base64Image mime im) = String $ "data:" <> mime <> ";base64," <> T.E.decodeUtf8 im  -- | @getMimeType bs@ returns a possible mimetype for the given bytestring, -- based on the first few magic bytes. It may return any of PNG/JPEG/GIF or WEBP@@ -325,13 +309,13 @@ getMimeType :: B.ByteString -> Maybe T.Text getMimeType bs   | B.take 8 bs == "\x89\x50\x4E\x47\x0D\x0A\x1A\x0A"-  = Just "image/png"+      = Just "image/png"   | B.take 3 bs == "\xff\xd8\xff" || B.take 4 (B.drop 6 bs) `elem` ["JFIF", "Exif"]-  = Just "image/jpeg"+      = Just "image/jpeg"   | B.take 6 bs == "\x47\x49\x46\x38\x37\x61" || B.take 6 bs == "\x47\x49\x46\x38\x39\x61"-  = Just "image/gif"+      = Just "image/gif"   | B.take 4 bs == "RIFF" && B.take 4 (B.drop 8 bs) == "WEBP"-  = Just "image/webp"+      = Just "image/webp"   | otherwise = Nothing  -- | The different channel types. Used for application commands and components.

@@ -18,8 +18,9 @@     Role (rolePerms),     roleIdToRole,   )-import Discord.Internal.Types.Prelude (RolePermissions)+import Discord.Internal.Types.Prelude (RolePermissions (..)) import Discord.Internal.Types.User (GuildMember (memberRoles))+import Data.Foldable (foldl')  data PermissionFlag   = CREATE_INSTANT_INVITE@@ -66,7 +67,7 @@   deriving (Eq, Ord, Enum, Show)  permissionBits :: PermissionFlag -> RolePermissions-permissionBits p = shift 1 (fromEnum p)+permissionBits p = shift (RolePermissions 1) (fromEnum p)  -- | Check if a given role has all the permissions hasRolePermissions :: [PermissionFlag] -> RolePermissions -> Bool@@ -76,7 +77,7 @@  -- | Check if a given role has the permission hasRolePermission :: PermissionFlag -> RolePermissions -> Bool-hasRolePermission p r = (.&.) (permissionBits p) r > 0+hasRolePermission p r = getRolePermissions (permissionBits p .&. r) > 0  -- | Replace a users rolePerms --   with a complete new set of permissions@@ -105,7 +106,7 @@ clearRolePermission p = (.&.) (complement . permissionBits $ p)  combinePermissions :: [PermissionFlag] -> RolePermissions-combinePermissions = foldr ((.|.) . permissionBits) 0+combinePermissions = foldl' (\rp -> (rp .|.) . permissionBits) (RolePermissions 0)  -- | Check if any Role of an GuildMember has the needed permission --   If the result of roleIdToRole is Nothing, it prepends a "False"

@@ -1,5 +1,6 @@ module Discord.Requests   ( module Discord.Internal.Rest.Channel+  , module Discord.Internal.Rest.ApplicationInfo   , module Discord.Internal.Rest.Emoji   , module Discord.Internal.Rest.Guild   , module Discord.Internal.Rest.Invite@@ -11,6 +12,7 @@   , module Discord.Internal.Rest.ScheduledEvents   ) where +import Discord.Internal.Rest.ApplicationInfo import Discord.Internal.Rest.Channel import Discord.Internal.Rest.Emoji import Discord.Internal.Rest.Guild