From ae18b594c97782cc201ffa365f12064831b1ec93 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Thu, 11 Jan 2024 20:42:57 -0500 Subject: Handle stickers, properly handle exceptions in threads --- deps/discord-haskell/.github/workflows/main.yml | 43 ++++++++++----- deps/discord-haskell/changelog.md | 27 +++++++++- deps/discord-haskell/discord-haskell.cabal | 24 +++++---- deps/discord-haskell/docs/cache.md | 8 ++- .../examples/interaction-commands.hs | 10 ++-- deps/discord-haskell/examples/ping-pong.hs | 6 +-- deps/discord-haskell/src/Discord.hs | 28 +++++----- .../src/Discord/Internal/Gateway.hs | 5 +- .../src/Discord/Internal/Gateway/Cache.hs | 62 +++++++++------------- .../src/Discord/Internal/Rest/ApplicationInfo.hs | 38 +++++++++++++ .../src/Discord/Internal/Rest/Channel.hs | 44 ++++++++++----- .../src/Discord/Internal/Rest/Emoji.hs | 11 ++-- .../src/Discord/Internal/Rest/Guild.hs | 33 ++++++++++-- .../src/Discord/Internal/Rest/User.hs | 3 +- .../src/Discord/Internal/Rest/Webhook.hs | 3 +- deps/discord-haskell/src/Discord/Internal/Types.hs | 3 ++ .../src/Discord/Internal/Types/ApplicationInfo.hs | 23 ++++++++ .../src/Discord/Internal/Types/Channel.hs | 45 ++++++++++++---- .../src/Discord/Internal/Types/Emoji.hs | 2 + .../src/Discord/Internal/Types/Events.hs | 26 ++++++--- .../src/Discord/Internal/Types/Gateway.hs | 11 ++-- .../src/Discord/Internal/Types/Guild.hs | 51 ++++++++++++++---- .../src/Discord/Internal/Types/Interactions.hs | 1 + .../src/Discord/Internal/Types/Prelude.hs | 42 +++++---------- .../src/Discord/Internal/Types/RolePermissions.hs | 9 ++-- deps/discord-haskell/src/Discord/Requests.hs | 2 + deps/discord-haskell/stack.yaml | 5 +- 27 files changed, 382 insertions(+), 183 deletions(-) create mode 100644 deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs create mode 100644 deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs (limited to 'deps/discord-haskell') diff --git a/deps/discord-haskell/.github/workflows/main.yml b/deps/discord-haskell/.github/workflows/main.yml index aec9070..0d5aa65 100644 --- a/deps/discord-haskell/.github/workflows/main.yml +++ b/deps/discord-haskell/.github/workflows/main.yml @@ -14,8 +14,11 @@ jobs: # and use fromJson in the next job to construct the matrix. # This dynamic approach means we don't have to update the CI file when we # change supported GHC versions. + # + # Only the Cabal build job will use the generated matrix, since Stack has a + # pinned GHC version in the stack.yaml file. generate-matrix: - name: Generate GHC build matrix + name: Generate GHC build matrix for Cabal runs-on: ubuntu-latest outputs: ghc-matrix: ${{ steps.set-ghc-matrix.outputs.versions }} @@ -25,17 +28,17 @@ jobs: - name: Parse the cabal tested-with stanza id: parse run: | - echo "::set-output name=tested-with-versions::$(runghc .github/workflows/parseVersions.hs)" + echo "tested-with-versions=$(runghc .github/workflows/parseVersions.hs)" >> $GITHUB_OUTPUT - name: Set the GHC matrix for the next job id: set-ghc-matrix # We use single quotes here, since the output from the previous step # will not have escaped double quotes, and it's just easier to use single # quotes on the outside than try to escape the inner double quotes. - run: echo '::set-output name=versions::{"ghc-version":${{ steps.parse.outputs.tested-with-versions }}}' + run: echo 'versions={"ghc-version":${{ steps.parse.outputs.tested-with-versions }}}' >> $GITHUB_OUTPUT - build: - name: Build Check + build-cabal: + name: Cabal Build Check needs: generate-matrix runs-on: ubuntu-latest strategy: @@ -48,14 +51,16 @@ jobs: steps: - uses: actions/checkout@v2 + # Although the GitHub Action Runner comes with pre-installed Cabal and GHC, + # we'll only use Cabal out of the box since that is independent of + # the GHC version. For GHC, we'll use the Haskell setup action to install + # the correct version needed for the build. - uses: haskell/actions/setup@v2 id: setup-haskell with: - # We install a global GHC and use Stack with --system-ghc + # We install a global GHC ghc-version: ${{ matrix.ghc-version }} - enable-stack: true - # First run cabal, since it is generally quicker - name: "Cabal: Update cabal package database, generate build plan" run: | cabal update @@ -77,15 +82,29 @@ jobs: - name: "Cabal: Build" run: cabal build - # Now run stack + build-stack: + name: Stack Build Check + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2 + + # Since the GitHub Action Runner comes with a pre-installed Stack, we'll + # use that instead of installing our own through the Haskell setup action, + # since all we need to test the stack build is Stack itself. + - name: "Stack: Cache ~/.stack" id: cache-stack uses: actions/cache@v2 with: path: ~/.stack - key: stack-${{ runner.os }}-${{ matrix.ghc-version }}-${{ hashFiles('stack.yaml') }} + key: stack-${{ runner.os }}-${{ hashFiles('stack.yaml') }} restore-keys: | - stack-${{ runner.os }}-${{ matrix.ghc-version }} + stack-${{ runner.os }} + + - name: "Print GHC version resolved from stack.yaml" + run: | + stack ghc -- --version + stack path --compiler-exe - name: "Stack: Build" - run: stack build --system-ghc + run: stack build diff --git a/deps/discord-haskell/changelog.md b/deps/discord-haskell/changelog.md index 371ea02..d5b64ab 100644 --- a/deps/discord-haskell/changelog.md +++ b/deps/discord-haskell/changelog.md @@ -4,10 +4,35 @@ View on GitHub for the newest ChangeLog: https://github.com/discord-haskell/disc 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 + +- [penelopeysm](https://github.com/discord-haskell/discord-haskell/pull/176) GHC 9.6 dependencies + +- [penelopeysm](https://github.com/discord-haskell/discord-haskell/pull/179) and [penelopeysm](https://github.com/discord-haskell/discord-haskell/pull/181) Improving emoji support + +- [penelopeysm](https://github.com/discord-haskell/discord-haskell/pull/182) Fix StartThreadNoMessage endpoint + +- [yutotakano](https://github.com/discord-haskell/discord-haskell/pull/183) Slim down stack matrix build + +## 1.15.5 + +- [Gregory1234](https://github.com/discord-haskell/discord-haskell/pull/173) Adding `global_name` field to the User object + ## 1.15.4 - [matobet](https://github.com/discord-haskell/discord-haskell/pull/148) Adding GHC 9.2.* support diff --git a/deps/discord-haskell/discord-haskell.cabal b/deps/discord-haskell/discord-haskell.cabal index 08faa6b..1e8fc96 100644 --- a/deps/discord-haskell/discord-haskell.cabal +++ b/deps/discord-haskell/discord-haskell.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: discord-haskell -version: 1.15.4 +version: 1.16.0 description: Functions and data types to write discord bots. Official discord docs . . @@ -19,6 +19,7 @@ build-type: Simple tested-with: GHC == 8.10.7 , GHC == 9.2 , GHC == 9.4 + , GHC == 9.6 extra-doc-files: README.md , changelog.md @@ -139,6 +140,7 @@ library , 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 @@ -150,6 +152,7 @@ library , 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 @@ -158,27 +161,28 @@ library , Discord.Internal.Types.ScheduledEvents build-depends: -- 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.* - base == 4.14.* || == 4.15.* || == 4.16.* || == 4.17.*, - aeson >= 1.5 && < 1.6 || >= 2.0 && < 2.2, + -- 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 >= 2.0 && < 2.3, async >=2.2 && <2.3, - bytestring >=0.10 && <0.12, + bytestring >=0.10 && <0.13, base64-bytestring >=1.1 && <1.3, containers >=0.6 && <0.7, data-default >=0.7 && <0.8, - emoji ==0.1.*, + -- emojis >=0.1.3 && <0.2, + emojis, http-client >=0.6 && <0.8, iso8601-time >=0.1 && <0.2, - MonadRandom >=0.5 && <0.6, + MonadRandom >=0.5 && <0.7, req >=3.9 && <3.14, safe-exceptions >=0.1 && <0.2, text >=1.2 && <3, - time, + time >=1.9 && <1.13, websockets >=0.12 && <0.13, network >=3.0.0.0 && <3.2.0.0, wuss >=1.1 && <3, - mtl >=2.2 && <2.3, + mtl >=2.2 && <2.4, unliftio >=0.2 && <0.3, scientific >=0.3 && <0.4, - http-api-data >=0.4 && <0.6, + http-api-data >=0.4 && <0.7, unordered-containers >=0.2.10.0 && <0.3 diff --git a/deps/discord-haskell/docs/cache.md b/deps/discord-haskell/docs/cache.md index c3f91b5..5303f88 100644 --- a/deps/discord-haskell/docs/cache.md +++ b/deps/discord-haskell/docs/cache.md @@ -1,7 +1,11 @@ ### Cache -The cache (`readCache`) is currently deprecated. +The cache (`readCache`) is a work in progress. -It's capable of working, but the code to update is not written. +The CurrentUser and Application fields are filled before the onStart handler is called. + +Other fields are not filled in by default. If `RunDiscordOpts.discordEnableCache` is `true` then they will be filled in as the gateay receives events. + +No rest requests are cached (yet, WIP). Current source code is at [Discord.Internal.Gateway.Cache](../src/Discord/Internal/Gateway/Cache.hs) diff --git a/deps/discord-haskell/examples/interaction-commands.hs b/deps/discord-haskell/examples/interaction-commands.hs index 7d22825..50e0b1d 100644 --- a/deps/discord-haskell/examples/interaction-commands.hs +++ b/deps/discord-haskell/examples/interaction-commands.hs @@ -54,15 +54,11 @@ interactionCommandExample = do -- 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 @@ eventHandler testserverid event = case event of void ( do exampleImage <- liftIO getImage - aid <- readCache <&> cacheApplication <&> partialApplicationID + aid <- readCache <&> cacheApplication <&> fullApplicationID _ <- restCall (R.CreateInteractionResponse interactionId interactionToken InteractionResponseDeferChannelMessage) restCall ( R.CreateFollowupInteractionMessage diff --git a/deps/discord-haskell/examples/ping-pong.hs b/deps/discord-haskell/examples/ping-pong.hs index 87ec08b..3dff866 100644 --- a/deps/discord-haskell/examples/ping-pong.hs +++ b/deps/discord-haskell/examples/ping-pong.hs @@ -42,11 +42,9 @@ startHandler :: GuildId -> DiscordHandler () 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 } diff --git a/deps/discord-haskell/src/Discord.hs b/deps/discord-haskell/src/Discord.hs index 5ed8bcf..7470c50 100644 --- a/deps/discord-haskell/src/Discord.hs +++ b/deps/discord-haskell/src/Discord.hs @@ -26,7 +26,8 @@ module Discord import Prelude hiding (log) import Control.Exception (Exception) -import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever, asks) +import Control.Monad (void, forever) +import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO, asks) import Data.Aeson (FromJSON) import Data.Default (Default, def) import Data.IORef (writeIORef) @@ -41,6 +42,7 @@ import Discord.Handle 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 @@ -115,18 +117,24 @@ runDiscord opts = do -- | 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 @@ -187,11 +195,7 @@ sendCommand e = do 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 () diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Gateway.hs index f07be39..a31c4de 100644 --- a/deps/discord-haskell/src/Discord/Internal/Gateway.hs +++ b/deps/discord-haskell/src/Discord/Internal/Gateway.hs @@ -7,6 +7,7 @@ module Discord.Internal.Gateway , CacheHandle(..) , GatewayException(..) , Cache(..) + , initializeCache , startCacheThread , startGatewayThread , module Discord.Internal.Types @@ -21,13 +22,13 @@ import Data.Time (getCurrentTime) 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) diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs index a4f228a..9ae3257 100644 --- a/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs +++ b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs @@ -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 qualified Data.Text as T 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 diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs new file mode 100644 index 0000000..f0ad7f2 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationInfo.hs @@ -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 +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 diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs index 1024d9d..82b402c 100644 --- a/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs @@ -22,7 +22,7 @@ module Discord.Internal.Rest.Channel import Data.Aeson import Data.Default (Default, def) -import Data.Emoji (unicodeByName) +import Text.Emoji (emojiFromAlias) import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -159,16 +159,14 @@ instance Default MessageDetailedOpts where } -- | Data constructor for `GetReactions` requests -data ReactionTiming = BeforeReaction MessageId - | AfterReaction MessageId - | LatestReaction +data ReactionTiming = AfterUser UserId + | FirstUsers deriving (Show, Read, Eq, Ord) 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 + (AfterUser snow) -> "after" R.=: show snow + FirstUsers -> mempty -- | Data constructor for `GetChannelMessages` requests. -- @@ -310,6 +308,12 @@ instance ToJSON StartThreadOpts where , "rate_limit_per_user" .=? startThreadRateLimit ] +instance Default StartThreadOpts where + def = StartThreadOpts { startThreadName = "New Thread" + , startThreadAutoArchive = Nothing + , startThreadRateLimit = Nothing + } + -- | Options for `StartThreadNoMessage` request data StartThreadNoMessageOpts = StartThreadNoMessageOpts { -- | Base options for the thread @@ -401,11 +405,25 @@ channelMajorRoute c = case c of 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 + noColons = T.replace ":" "" emoji + toneModifier s = case s of + "tone1" -> Just "\x1f3fb" + "tone2" -> Just "\x1f3fc" + "tone3" -> Just "\x1f3fd" + "tone4" -> Just "\x1f3fe" + "tone5" -> Just "\x1f3ff" + _ -> Nothing + byName = case emojiFromAlias noColons of + Just e -> Just e + Nothing -> + let (prefix, tone) = T.breakOnEnd "_" noColons + in case ((fst <$> T.unsnoc prefix) >>= emojiFromAlias, toneModifier tone) of + (Just p, Just t) -> Just (p <> t) + _ -> Nothing + in case (byName, T.stripPrefix ":" noAngles) of + (Just e, _) -> e + (_, Just a) -> "custom:" <> a + (_, Nothing) -> noAngles channels :: R.Url 'R.Https channels = baseUrl /: "channels" @@ -566,7 +584,7 @@ channelJsonRequest c = case c of mempty (StartThreadNoMessage chan sto) -> - Post (channels /~ chan /: "messages" /: "threads") + Post (channels /~ chan /: "threads") (pure $ R.ReqBodyJson $ toJSON sto) mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs index 2a52171..e849123 100644 --- a/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs @@ -20,7 +20,6 @@ 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 ((/:), (/~)) @@ -65,7 +64,7 @@ instance ToJSON ModifyGuildEmojiOpts where 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 @@ emojiJsonRequest c = case c of 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 diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs index a0cb3aa..99c3e77 100644 --- a/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs @@ -15,6 +15,7 @@ module Discord.Internal.Rest.Guild , ModifyGuildRoleOpts(..) , CreateGuildIntegrationOpts(..) , ModifyGuildIntegrationOpts(..) + , ListActiveThreads (..) ) where @@ -53,6 +54,8 @@ data GuildRequest a where -- '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] + -- | Returns a list of active threads in a guild + ListActiveGuildThreads :: GuildId -> GuildRequest ListActiveThreads -- | Returns a guild 'Member' object for the specified user GetGuildMember :: GuildId -> UserId -> GuildRequest GuildMember -- | Returns a list of guild 'Member' objects that are members of the guild. @@ -61,14 +64,13 @@ data GuildRequest a where -- 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 - -> GuildRequest () + AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts -> GuildRequest () -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember -- | Modify the nickname of the current user 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 () -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a @@ -132,11 +134,11 @@ data GuildRequest a where -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. 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 @@ -301,6 +303,23 @@ data GuildMembersTiming = GuildMembersTiming , guildMembersTimingAfter :: Maybe UserId } deriving (Show, Read, Eq, Ord) +-- | result for `ListGuildActiveThreads` +data ListActiveThreads = ListActiveThreads + { listActiveThreadsThreads :: [Channel] + , listActiveThreadsMembers :: [ThreadMember] + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ListActiveThreads where + toJSON ListActiveThreads{..} = object + [ ("threads", toJSON listActiveThreadsThreads) + , ("members", toJSON listActiveThreadsMembers) + ] + +instance FromJSON ListActiveThreads where + parseJSON = withObject "ListActiveThreads" $ \o -> + ListActiveThreads <$> o .: "threads" + <*> o .: "members" + guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) = let limit = case mLimit of @@ -319,6 +338,7 @@ guildMajorRoute c = case c of (GetGuildChannels g) -> "guild_chan " <> show g (CreateGuildChannel g _ _ _) -> "guild_chan " <> show g (ModifyGuildChannelPositions g _) -> "guild_chan " <> show g + (ListActiveGuildThreads g) -> "guild_chan " <> show g (GetGuildMember g _) -> "guild_memb " <> show g (ListGuildMembers g _) -> "guild_membs " <> show g (AddGuildMember g _ _) -> "guild_membs " <> show g @@ -376,6 +396,9 @@ guildJsonRequest c = case c of ,("position", toJSON b)]) newlocs in Patch (guilds /~ guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + (ListActiveGuildThreads guild) -> + Get (guilds /~ guild /: "threads" /: "active") mempty + (GetGuildMember guild member) -> Get (guilds /~ guild /: "members" /~ member) mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/User.hs b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs index 28c0505..2ab9c24 100644 --- a/deps/discord-haskell/src/Discord/Internal/Rest/User.hs +++ b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs @@ -15,7 +15,6 @@ import Data.Aeson 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 @@ data UserRequest a where -- 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 diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs index 7b4a545..be39b09 100644 --- a/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs @@ -13,6 +13,7 @@ module Discord.Internal.Rest.Webhook ) 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 @@ data WebhookContent = WebhookContentText T.Text | 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 _ _ -> [] diff --git a/deps/discord-haskell/src/Discord/Internal/Types.hs b/deps/discord-haskell/src/Discord/Internal/Types.hs index 0dac11c..e115f9a 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types.hs @@ -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 @@ where 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 @@ -41,6 +43,7 @@ userFacingEvent event = case event of InternalChannelDelete a -> ChannelDelete a InternalThreadCreate a -> ThreadCreate a InternalThreadUpdate a -> ThreadUpdate a + InternalThreadMemberUpdate a -> ThreadMemberUpdate a InternalThreadDelete a -> ThreadDelete a InternalThreadListSync a -> ThreadListSync a InternalThreadMembersUpdate a -> ThreadMembersUpdate a diff --git a/deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs new file mode 100644 index 0000000..708f1c7 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationInfo.hs @@ -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" + diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs index 9f4671a..a577f64 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs @@ -9,6 +9,7 @@ module Discord.Internal.Types.Channel ( , Overwrite (..) , ThreadMetadata (..) , ThreadMember (..) + , ThreadMemberUpdateFields (..) , ThreadListSyncFields (..) , ThreadMembersUpdateFields (..) , Message (..) @@ -23,7 +24,7 @@ module Discord.Internal.Types.Channel ( , MessageFlag (..) , MessageFlags (..) , MessageInteraction (..) - + , ChannelTypeOption (..) ) where @@ -170,7 +171,7 @@ instance FromJSON Channel where case type' of 0 -> ChannelText <$> o .: "id" - <*> o .:? "guild_id" .!= 0 + <*> o .: "guild_id" <*> o .: "name" <*> o .: "position" <*> o .: "permission_overwrites" @@ -185,7 +186,7 @@ instance FromJSON Channel where <*> o .:? "last_message_id" 2 -> ChannelVoice <$> o .: "id" - <*> o .:? "guild_id" .!= 0 + <*> o .: "guild_id" <*> o .: "name" <*> o .: "position" <*> o .: "permission_overwrites" @@ -199,13 +200,13 @@ instance FromJSON Channel where <*> 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 +216,14 @@ instance FromJSON Channel where <*> 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 +231,7 @@ instance FromJSON Channel where <*> 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 +239,7 @@ instance FromJSON Channel where <*> 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 +248,7 @@ instance FromJSON Channel where <*> o .:? "member" 13 -> ChannelStage <$> o .: "id" - <*> o .:? "guild_id" .!= 0 + <*> o .: "guild_id" <*> o .: "id" <*> o .:? "topic" .!= "" _ -> ChannelUnknownType <$> o .: "id" @@ -453,6 +454,30 @@ instance ToJSON ThreadMember where , "flags" .== threadMemberFlags ] +data ThreadMemberUpdateFields = ThreadMemberUpdateFields + { threadMemberUpdateFieldsThreadId :: Maybe ChannelId -- ^ id of the thread + , threadMemberUpdateFieldsUserId :: Maybe UserId -- ^ id of the user + , threadMemberUpdateFieldsJoinTime :: UTCTime -- ^ time the current user last joined the thread + , threadMemberUpdateFieldsFlags :: Integer -- ^ user-thread settings + , threadMemberUpdateFieldsGuildId :: GuildId -- ^ id of the guild + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMemberUpdateFields where + parseJSON = withObject "ThreadMemberUpdateFields" $ \o -> + ThreadMemberUpdateFields <$> o .:? "id" + <*> o .:? "user_id" + <*> o .: "join_timestamp" + <*> o .: "flags" + <*> o .: "guild_id" + +instance ToJSON ThreadMemberUpdateFields where + toJSON ThreadMemberUpdateFields{..} = objectFromMaybes + [ "id" .=? threadMemberUpdateFieldsThreadId + , "user_id" .=? threadMemberUpdateFieldsUserId + , "join_timestamp" .== threadMemberUpdateFieldsJoinTime + , "flags" .== threadMemberUpdateFieldsFlags + , "guild_id" .== threadMemberUpdateFieldsGuildId + ] data ThreadListSyncFields = ThreadListSyncFields { threadListSyncFieldsGuildId :: GuildId diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs index 9023d4a..4e0408c 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs @@ -152,6 +152,7 @@ data StickerFormatType = StickerFormatTypePNG | StickerFormatTypeAPNG | StickerFormatTypeLOTTIE + | StickerFormatTypeGIF deriving (Show, Read, Eq, Ord, Data) instance InternalDiscordEnum StickerFormatType where @@ -159,6 +160,7 @@ instance InternalDiscordEnum StickerFormatType where fromDiscordType StickerFormatTypePNG = 1 fromDiscordType StickerFormatTypeAPNG = 2 fromDiscordType StickerFormatTypeLOTTIE = 3 + fromDiscordType StickerFormatTypeGIF = 4 instance ToJSON StickerFormatType where toJSON = toJSON . fromDiscordType diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Events.hs b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs index d77cc96..5014d9f 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Events.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs @@ -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 Network.Socket (HostName) 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 @@ -39,11 +41,13 @@ data Event = | ThreadCreate Channel -- | thread was updated | ThreadUpdate Channel + -- | thread member for the current user was updated + | ThreadMemberUpdate ThreadMemberUpdateFields -- | thread was deleted | ThreadDelete Channel -- | sent when gaining access to a channel, contains all active threads in that channel | ThreadListSync ThreadListSyncFields - -- | thread member for the current user was updated + -- | member or the current user was added or removed from a thread | ThreadMembersUpdate ThreadMembersUpdateFields -- | message was pinned or unpinned | ChannelPinsUpdate ChannelId (Maybe UTCTime) @@ -116,6 +120,7 @@ data EventInternalParse = | InternalChannelDelete Channel | InternalThreadCreate Channel | InternalThreadUpdate Channel + | InternalThreadMemberUpdate ThreadMemberUpdateFields | InternalThreadDelete Channel | InternalThreadListSync ThreadListSyncFields | InternalThreadMembersUpdate ThreadMembersUpdateFields @@ -174,17 +179,25 @@ data GuildCreateData = GuildCreateData , 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 @@ -268,6 +281,7 @@ eventParse t o = case t of "CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o "THREAD_CREATE" -> InternalThreadCreate <$> reparse o "THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o + "THREAD_MEMBER_UPDATE" -> InternalThreadMemberUpdate <$> reparse o "THREAD_DELETE" -> InternalThreadDelete <$> reparse o "THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o "THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o @@ -275,7 +289,7 @@ eventParse t o = case t of 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" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs index a3b8f90..8ec1fed 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs @@ -129,9 +129,10 @@ data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts 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 GatewaySendableInternal where ] 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)) = diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs index 5bddfaf..d8f2cf3 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs @@ -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,15 +9,17 @@ module Discord.Internal.Types.Guild where 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 @@ instance FromJSON GuildUnavailable where 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 @@ data Activity = -- 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 @@ -180,6 +203,14 @@ instance FromJSON Activity where <*> 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 , activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs index 173f908..d56006e 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs @@ -18,6 +18,7 @@ module Discord.Internal.Types.Interactions InteractionToken, ResolvedData (..), MemberOrUser (..), + ModalData (..), InteractionResponse (..), interactionResponseBasic, InteractionResponseAutocomplete (..), diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs index fd49a15..67b3ec2 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs @@ -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 @@ module Discord.Internal.Types.Prelude , (.==) , (.=?) - , AesonKey , objectFromMaybes , ChannelTypeOption (..) @@ -71,10 +69,8 @@ import Web.Internal.HttpApiData 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 @@ authToken (Auth tok) = let token = T.strip tok -- | 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 @@ instance ToHttpApiData Snowflake where 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 @@ instance Show RolePermissions where 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 @@ type Shard = (Int, Int) -- | 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 @@ class Data a => InternalDiscordEnum a where | 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 @@ objectFromMaybes = object . catMaybes -- -- 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 @@ data Base64Image a = Base64Image T.Text T.Text -- -- 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 @@ instance ToJSON (Base64Image a) where 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. diff --git a/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs index 3044e9e..6a760d7 100644 --- a/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs +++ b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs @@ -18,8 +18,9 @@ import Discord.Internal.Types.Guild 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 @@ data PermissionFlag 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 @@ hasRolePermissions permissions rolePermissions = (.&.) combinedPermissions roleP -- | 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 :: PermissionFlag -> RolePermissions -> RolePermissions 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" diff --git a/deps/discord-haskell/src/Discord/Requests.hs b/deps/discord-haskell/src/Discord/Requests.hs index 6f2127e..34af25c 100644 --- a/deps/discord-haskell/src/Discord/Requests.hs +++ b/deps/discord-haskell/src/Discord/Requests.hs @@ -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.Requests , 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 diff --git a/deps/discord-haskell/stack.yaml b/deps/discord-haskell/stack.yaml index e1950a4..35f438f 100644 --- a/deps/discord-haskell/stack.yaml +++ b/deps/discord-haskell/stack.yaml @@ -2,11 +2,10 @@ extra-package-dbs: [] packages: - '.' -resolver: lts-18.28 +resolver: lts-20.26 extra-deps: -- emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273 - + - emojis-0.1.3 nix: packages: [ zlib, gmp ] -- cgit v1.2.3