discord-haskell 1.15.3 → 1.15.4

raw patch · 22 files changed

+748/−193 lines, 22 filesdep ~basedep ~textdep ~unliftionew-component:exe:interaction-commands-simplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, text, unliftio

API changes (from Hackage documentation)

Files

• changelog.md +26/−0
• discord-haskell.cabal +26/−9
• examples/interaction-commands-simple.hs +125/−0
• examples/interaction-commands.hs +21/−3
• examples/ping-pong.hs +4/−1
• src/Discord.hs +37/−3
• src/Discord/Internal/Gateway.hs +9/−8
• src/Discord/Internal/Gateway/Cache.hs +47/−35
• src/Discord/Internal/Gateway/EventLoop.hs +31/−17
• src/Discord/Internal/Rest/Guild.hs +4/−2
• src/Discord/Internal/Rest/ScheduledEvents.hs +73/−0
• src/Discord/Internal/Types.hs +3/−1
• src/Discord/Internal/Types/ApplicationCommands.hs +9/−56
• src/Discord/Internal/Types/Channel.hs +23/−2
• src/Discord/Internal/Types/Components.hs +39/−18
• src/Discord/Internal/Types/Events.hs +32/−5
• src/Discord/Internal/Types/Guild.hs +15/−29
• src/Discord/Internal/Types/Interactions.hs +28/−4
• src/Discord/Internal/Types/Prelude.hs +74/−0
• src/Discord/Internal/Types/RolePermissions.hs +119/−0
• src/Discord/Internal/Types/ScheduledEvents.hs +1/−0
• src/Discord/Requests.hs +2/−0

@@ -8,6 +8,32 @@  - +## 1.15.4++- [matobet](https://github.com/discord-haskell/discord-haskell/pull/148) Adding GHC 9.2.* support++- [aquarial](https://github.com/discord-haskell/discord-haskell/pull/149) Slash command validation extends to numbers++- [0x3alex](https://github.com/discord-haskell/discord-haskell/pull/152) Permissions bit flags++- [yutotakano](https://github.com/discord-haskell/discord-haskell/pull/153) Extending CI testing++- [1Computer1](https://github.com/discord-haskell/discord-haskell/pull/154) Exporting some internal types++- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/155) Select menu additions++- [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/158) Caching more information++- [tam-carre](https://github.com/discord-haskell/discord-haskell/pull/159) New example for interactions++- [XanderDJ](https://github.com/discord-haskell/discord-haskell/pull/164) New role permissions setup++- [chuahao](https://github.com/discord-haskell/discord-haskell/pull/168) Fixing parsing of permissions++- [chuahao](https://github.com/discord-haskell/discord-haskell/pull/169) Adding role icon to `ModifyGuildRoleOpts`++- [chuahao](https://github.com/discord-haskell/discord-haskell/pull/170) Add utilities to measure the latency to discord+ ## 1.15.3  - [L0neGamer](https://github.com/discord-haskell/discord-haskell/pull/145) Fixing behind the scenes for hackage

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                discord-haskell-version:             1.15.3+version:             1.15.4 description:         Functions and data types to write discord bots.                      Official discord docs <https://discord.com/developers/docs/reference>.                      .@@ -16,6 +16,9 @@ copyright:           2019 Karl category:            Network build-type:          Simple+tested-with:         GHC == 8.10.7+                   , GHC == 9.2+                   , GHC == 9.4 extra-doc-files:     README.md                    , changelog.md @@ -48,6 +51,18 @@                      , discord-haskell                      , bytestring +executable interaction-commands-simple+  main-is:             interaction-commands-simple.hs+  default-language:    Haskell2010+  ghc-options:         -Wall -fno-warn-type-defaults -fno-warn-unused-record-wildcards -threaded+  hs-source-dirs:      examples+  other-modules:+    ExampleUtils+  build-depends:       base+                     , text+                     , unliftio+                     , discord-haskell+ executable cache   main-is:             cache.hs   default-language:    Haskell2010@@ -125,6 +140,7 @@     , Discord.Internal.Rest.Webhook     , Discord.Internal.Rest.ApplicationCommands     , Discord.Internal.Rest.Interactions+    , Discord.Internal.Rest.ScheduledEvents     , Discord.Internal.Types     , Discord.Internal.Types.Prelude     , Discord.Internal.Types.Channel@@ -138,28 +154,29 @@     , Discord.Internal.Types.Components     , Discord.Internal.Types.Color     , Discord.Internal.Types.Emoji+    , Discord.Internal.Types.RolePermissions     , 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.*.-    base == 4.14.* || == 4.15.*,+  -- 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,     async >=2.2 && <2.3,-    bytestring >=0.10 && <0.11,-    base64-bytestring >=1.1 && <1.2,+    bytestring >=0.10 && <0.12,+    base64-bytestring >=1.1 && <1.3,     containers >=0.6 && <0.7,     data-default >=0.7 && <0.8,     emoji ==0.1.*,     http-client >=0.6 && <0.8,     iso8601-time >=0.1 && <0.2,     MonadRandom >=0.5 && <0.6,-    req >=3.9 && <3.13,+    req >=3.9 && <3.14,     safe-exceptions >=0.1 && <0.2,-    text >=1.2 && <1.3,-    time >=1.9 && <1.10,+    text >=1.2 && <3,+    time >=1.9 && <1.12,     websockets >=0.12 && <0.13,     network >=3.0.0.0 && <3.2.0.0,-    wuss >=1.1 && <1.2,+    wuss >=1.1 && <3,     mtl >=2.2 && <2.3,     unliftio >=0.2 && <0.3,     scientific >=0.3 && <0.4,

@@ -0,0 +1,125 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++import Discord+import Discord.Types+import Discord.Interactions+import UnliftIO (liftIO)+import Data.List (find)+import Control.Monad (forM_)+import ExampleUtils (getToken, getGuildId)+import Data.Text (Text)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO)+import qualified Discord.Requests as R+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+++-- MAIN++main :: IO ()+main = do+  tok <- getToken+  testGuildId <- getGuildId++  botTerminationError <- runDiscord $ def+    { discordToken = tok+    , discordOnEvent = onDiscordEvent testGuildId+    -- If you are using application commands, you might not need+    -- message contents at all+    , discordGatewayIntent = def { gatewayIntentMessageContent = False }+    }++  echo $ "A fatal error occurred: " <> botTerminationError+++-- UTILS++echo :: MonadIO m => Text -> m ()+echo = liftIO . TIO.putStrLn++showT :: Show a => a -> Text+showT = T.pack . show+++-- COMMANDS++data SlashCommand = SlashCommand+  { name :: Text+  , registration :: Maybe CreateApplicationCommand+  , handler :: Interaction -> Maybe OptionsData -> DiscordHandler ()+  }++mySlashCommands :: [SlashCommand]+mySlashCommands = [ping]++ping :: SlashCommand+ping = SlashCommand+  { name = "ping"+  , registration = createChatInput "ping" "responds pong"+  , handler = \intr _options ->+      void . restCall $+        R.CreateInteractionResponse+          (interactionId intr)+          (interactionToken intr)+          (interactionResponseBasic  "pong")+  }+++-- EVENTS++onDiscordEvent :: GuildId -> Event -> DiscordHandler ()+onDiscordEvent testGuildId = \case+  Ready _ _ _ _ _ _ (PartialApplication appId _) -> onReady appId testGuildId+  InteractionCreate intr                         -> onInteractionCreate intr+  _                                              -> pure ()++onReady :: ApplicationId -> GuildId -> DiscordHandler ()+onReady appId testGuildId = do+  echo "Bot ready!"++  appCmdRegistrations <- mapM tryRegistering mySlashCommands++  case sequence appCmdRegistrations of+    Left err ->+      echo $ "[!] Failed to register some commands" <> showT err++    Right cmds -> do+      echo $ "Registered " <> showT (length cmds) <> " command(s)."+      unregisterOutdatedCmds cmds++  where+  tryRegistering cmd = case registration cmd of+    Just reg -> restCall $ R.CreateGuildApplicationCommand appId testGuildId reg+    Nothing  -> pure . Left $ RestCallErrorCode 0 "" ""++  unregisterOutdatedCmds validCmds = do+    registered <- restCall $ R.GetGuildApplicationCommands appId testGuildId+    case registered of+      Left err ->+        echo $ "Failed to get registered slash commands: " <> showT err++      Right cmds ->+        let validIds    = map applicationCommandId validCmds+            outdatedIds = filter (`notElem` validIds)+                        . map applicationCommandId+                        $ cmds+         in forM_ outdatedIds $+              restCall . R.DeleteGuildApplicationCommand appId testGuildId++onInteractionCreate :: Interaction -> DiscordHandler ()+onInteractionCreate = \case+  cmd@InteractionApplicationCommand+    { applicationCommandData = input@ApplicationCommandDataChatInput {} } ->+      case+        find (\c -> applicationCommandDataName input == name c) mySlashCommands+      of+        Just found ->+          handler found cmd (optionsData input)++        Nothing ->+          echo "Somehow got unknown slash command (registrations out of date?)"++  _ ->+    pure () -- Unexpected/unsupported interaction type

@@ -188,7 +188,7 @@                               "testing asking for a channel"                               Nothing                               False-                              (Just [ApplicationCommandChannelTypeGuildVoice]),+                              (Just [ChannelTypeOptionGuildVoice]),                             OptionValueMentionable                               "mentionable"                               Nothing@@ -284,15 +284,33 @@                       ( SelectMenu                           "action select menu"                           False-                          [ SelectOption "First option" "opt1" (Just "the only desc") Nothing Nothing,+                          (SelectMenuDataText [ SelectOption "First option" "opt1" (Just "the only desc") Nothing Nothing,                             SelectOption "Second option" "opt2" Nothing (Just (mkEmoji "😭")) (Just True),                             SelectOption "third option" "opt3" Nothing Nothing Nothing,                             SelectOption "fourth option" "opt4" Nothing Nothing Nothing,                             SelectOption "fifth option" "opt5" Nothing Nothing Nothing-                          ]+                          ])                           (Just "this is a place holder")                           (Just 2)                           (Just 5)+                      ),+                    ActionRowSelectMenu+                      ( SelectMenu+                          "user select menu"+                          False+                          (SelectMenuDataUser)+                          (Just "this is a place holder")+                          (Just 3)+                          (Just 3)+                      ),+                    ActionRowSelectMenu+                      ( SelectMenu+                          "channel select menu"+                          False+                          (SelectMenuDataChannels [ChannelTypeOptionGuildText,ChannelTypeOptionGuildPublicThread,ChannelTypeOptionGuildCategory])+                          (Just "this is a place holder")+                          (Just 1)+                          (Just 1)                       )                   ],               R.messageDetailedEmbeds =

@@ -71,11 +71,14 @@         Right m' <- restCall (R.CreateMessage (messageChannelId m) "Pong")         void $ restCall (R.EditMessage (messageChannelId m, messageId m') (def {R.messageDetailedContent=messageContent m' <> "!"})) +        latency <- getGatewayLatency+        mLatency <- measureLatency+         -- A more complex message. Text-to-speech, does not mention everyone nor         -- the user, and uses Discord native replies.         -- Use ":info" in ghci to explore the type         let opts :: R.MessageDetailedOpts-            opts = def { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!"+            opts = def { R.messageDetailedContent = "Here's a more complex message, but doesn't ping @everyone!. Here's the current gateway latency: " <> (T.pack . show) ([latency, mLatency])                        , R.messageDetailedTTS = True                        , R.messageDetailedAllowedMentions = Just $                           def { R.mentionEveryone = False

@@ -10,6 +10,8 @@   , sendCommand   , readCache   , stopDiscord+  , getGatewayLatency+  , measureLatency    , DiscordHandler @@ -24,14 +26,15 @@  import Prelude hiding (log) import Control.Exception (Exception)-import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever)+import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever, asks) import Data.Aeson (FromJSON) import Data.Default (Default, def) import Data.IORef (writeIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) -import UnliftIO (race, try, finally, SomeException, IOException)+import UnliftIO (race, try, finally, SomeException, IOException, readIORef) import UnliftIO.Concurrent  import Discord.Handle@@ -66,6 +69,8 @@     discordForkThreadForEvents :: Bool   , -- | The gateway intents the bot is asking for     discordGatewayIntent :: GatewayIntent+  , -- | Whether to use the cache (may use a lot of memory, only enable if it will be used!)+    discordEnableCache :: Bool   }  -- | Default values for `RunDiscordOpts`@@ -77,6 +82,7 @@                        , discordOnLog = \_ -> pure ()                        , discordForkThreadForEvents = True                        , discordGatewayIntent = def+                       , discordEnableCache = False                        }  -- | Entrypoint to the library @@ -84,7 +90,7 @@ runDiscord opts = do   log <- newChan   logId <- liftIO $ startLogger (discordOnLog opts) log-  (cache, cacheId) <- liftIO $ startCacheThread log+  (cache, cacheId) <- liftIO $ startCacheThread (discordEnableCache opts) log   (rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log   (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) (discordGatewayIntent opts) cache log @@ -209,3 +215,31 @@          -- writeChan logC "Log handler failed"          pure () +-- | Read the gateway latency from the last time we sent and received a +-- Heartbeat. From Europe tends to give ~110ms+getGatewayLatency :: DiscordHandler NominalDiffTime+getGatewayLatency = do+  gw <- asks discordHandleGateway+  (send1, send2) <- readIORef (gatewayHandleHeartbeatTimes gw)++  ack <- readIORef (gatewayHandleHeartbeatAckTimes gw)++  pure . diffUTCTime ack $ +    if ack > send1 -- if the ack is before the send just gone, use the previous send+      then send1+      else send2++-- | Measure the current latency by making a request and measuring the time +-- taken. From Europe tends to give 200ms-800ms.+--+-- The request is getting the bot's user, which requires the `identify` scope.+measureLatency :: DiscordHandler NominalDiffTime+measureLatency = do+  startTime <- liftIO getCurrentTime+  _ <- restCall GetCurrentUser+  endTime <- liftIO getCurrentTime+  pure $ diffUTCTime endTime startTime++-- internal note: it seems bad that it's taking 2x-8x as much time to perform +-- this specific request, considering that the latency we expect is much less.+-- might be worth looking into efficiencies or a better event to use.

@@ -17,18 +17,19 @@ import Control.Concurrent (forkIO, ThreadId, newEmptyMVar, MVar) import Data.IORef (newIORef) import qualified Data.Text as T+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(..))  -- | Starts a thread for the cache-startCacheThread :: Chan T.Text -> IO (CacheHandle, ThreadId)-startCacheThread log = do+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))   let cacheHandle = CacheHandle events cache-  tid <- forkIO $ cacheLoop cacheHandle log+  tid <- forkIO $ cacheLoop isEnabled cacheHandle log   pure (cacheHandle, tid)  -- | Create a Chan for websockets. This creates a thread that@@ -40,10 +41,10 @@   status <- newIORef Nothing   seqid <- newIORef 0   seshid <- newIORef ""-  host <- newIORef $ "gateway.discord.gg"-  let gatewayHandle = GatewayHandle events sends status seqid seshid host+  host <- newIORef "gateway.discord.gg"+  currTime <- getCurrentTime+  hbAcks <- newIORef currTime+  hbSends <- newIORef (currTime, currTime)+  let gatewayHandle = GatewayHandle events sends status seqid seshid host hbAcks hbSends   tid <- forkIO $ connectionLoop auth intent gatewayHandle log   pure (gatewayHandle, tid)---

@@ -1,12 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}  -- | Query info about connected Guilds and Channels module Discord.Internal.Gateway.Cache where  import Prelude hiding (log)-import Control.Monad (forever)+import Control.Monad (forever, join) import Control.Concurrent.MVar import Control.Concurrent.Chan+import Data.Foldable (foldl') import qualified Data.Map.Strict as M import qualified Data.Text as T @@ -14,11 +16,11 @@ import Discord.Internal.Gateway.EventLoop  data Cache = Cache-     { cacheCurrentUser :: User-     , cacheDMChannels :: M.Map ChannelId Channel-     , cacheGuilds :: M.Map GuildId Guild-     , cacheChannels :: M.Map ChannelId Channel-     , cacheApplication :: PartialApplication+     { cacheCurrentUser :: !User+     , cacheDMChannels :: !(M.Map ChannelId Channel)+     , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData)))+     , cacheChannels :: !(M.Map ChannelId Channel)+     , cacheApplication :: !PartialApplication      } deriving (Show)  data CacheHandle = CacheHandle@@ -26,8 +28,8 @@   , cacheHandleCache  :: MVar (Either (Cache, GatewayException) Cache)   } -cacheLoop :: CacheHandle -> Chan T.Text -> IO ()-cacheLoop cacheHandle log = do+cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO ()+cacheLoop isEnabled cacheHandle log = do       ready <- readChan eventChan       case ready of         Right (InternalReady _ user _ _ _ _ pApp) -> do@@ -44,35 +46,45 @@   loop :: IO ()   loop = forever $ do     eventOrExcept <- readChan eventChan-    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))+    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  adjustCache :: Cache -> EventInternalParse -> Cache adjustCache minfo event = case event of-  InternalGuildCreate guild ->-    let newChans = maybe [] (map (setChanGuildID (guildId guild))) (guildChannels guild)-        g = M.insert (guildId guild) (guild { guildChannels = Just newChans }) (cacheGuilds minfo)-        c = M.unionWith const-                        (M.fromList [ (channelId ch, ch) | ch <- newChans ])-                        (cacheChannels minfo)+  InternalReady _ _ gus _ _ _ pa -> minfo { cacheApplication = pa, cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) }++  InternalGuildCreate guild guildData ->+    let newChans = guildCreateChannels guildData+        g = M.insert (guildId guild) (Just (guild, Just guildData)) (cacheGuilds minfo)+        c = M.union+              (M.fromList [ (channelId ch, ch) | ch <- newChans ])+              (cacheChannels minfo)     in minfo { cacheGuilds = g, cacheChannels = c }-  --InternalGuildUpdate guild -> do-  --  let g = M.insert (guildId guild) guild (cacheGuilds minfo)-  --      m2 = minfo { cacheGuilds = g }-  --  putMVar cache m2-  --InternalGuildDelete guild -> do-  --  let g = M.delete (guildId guild) (cacheGuilds minfo)-  --      c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (cacheChannels minfo)-  --      m2 = minfo { cacheGuilds = g, cacheChannels = c }-  --  putMVar cache m2-  InternalReady _ _ _ _ _ _ pa -> minfo { cacheApplication = pa }+  InternalGuildUpdate guild ->+    let gs = M.alter (\case Just (Just (_, mCD)) -> Just (Just (guild, mCD)) ; _ -> Just (Just (guild, Nothing)); ) (guildId guild) $ cacheGuilds minfo+    in minfo { cacheGuilds = gs }+  InternalGuildDelete guild ->+    let+      toDelete = join $ cacheGuilds minfo M.!? idOnceAvailable guild+      extraData = snd =<< toDelete+      channels = maybe [] (fmap channelId . guildCreateChannels) extraData+      g = M.delete (idOnceAvailable guild) (cacheGuilds minfo)+      c = foldl' (flip M.delete) (cacheChannels minfo) channels+    in minfo { cacheGuilds = g, cacheChannels = c }+  InternalChannelCreate c ->+    let cm = M.insert (channelId c) c (cacheChannels minfo)+    in minfo { cacheChannels = cm }+  InternalChannelUpdate c ->+    let cm = M.insert (channelId c) c (cacheChannels minfo)+    in minfo { cacheChannels = cm }+  InternalChannelDelete c ->+    let cm = M.delete (channelId c) (cacheChannels minfo)+    in minfo { cacheChannels = cm }   _ -> minfo--setChanGuildID :: GuildId -> Channel -> Channel-setChanGuildID s c = if channelIsInGuild c-                     then c { channelGuild = s }-                     else c

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  -- | Provides logic code for interacting with the Discord websocket --   gateway. Realistically, this is probably lower level than most@@ -18,6 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as BL+import Data.Time (getCurrentTime)  import Wuss (runSecureClient) import Network.Socket (HostName)@@ -45,14 +47,18 @@     -- may contain a different value. This should never contain trailing slashes,     -- or any "wss://" prefixes, since HostNames of this kind are not supported     -- by the websockets library.-    gatewayHandleHostname       :: IORef HostName+    gatewayHandleHostname       :: IORef HostName,+    -- | The last time a heartbeatack was received+    gatewayHandleHeartbeatAckTimes    :: IORef UTCTime,+    -- | The last two times a heartbeat was sent+    gatewayHandleHeartbeatTimes       :: IORef (UTCTime, UTCTime)   }  -- | Ways the gateway connection can fail with no possibility of recovery.-data GatewayException = GatewayExceptionIntent T.Text+newtype GatewayException = GatewayExceptionIntent T.Text   deriving (Show) - + -- | State of the eventloop data LoopState = LoopStart                | LoopClosed@@ -100,7 +106,7 @@               case nextstate :: Either SomeException LoopState of                 Left _ -> do t <- getRandomR (3,20)                              threadDelay (t * (10^(6 :: Int)))-                             writeChan log ("gateway - trying to reconnect after failure(s)")+                             writeChan log "gateway - trying to reconnect after failure(s)"                              outerloop LoopReconnect                 Right n -> outerloop n @@ -113,7 +119,7 @@         LoopReconnect -> do seqId  <- readIORef (gatewayHandleLastSequenceId gatewayHandle)                             seshId <- readIORef (gatewayHandleSessionId gatewayHandle)                             if seshId == ""-                            then do writeChan log ("gateway - WARNING seshID was not set by READY?")+                            then do writeChan log "gateway - WARNING seshID was not set by READY?"                                     pure $ Just $ Identify auth intent (0, 1)                             else pure $ Just $ Resume auth seshId seqId         LoopClosed -> pure Nothing@@ -140,7 +146,7 @@                                                             }                                 -- start websocket sending loop                                 sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log-                                heart <- forkIO $ heartbeat sending (gatewayHandleLastSequenceId gatewayHandle)+                                heart <- forkIO $ heartbeat sending (gatewayHandleHeartbeatTimes gatewayHandle) (gatewayHandleLastSequenceId gatewayHandle)                                 writeChan internal message                                  -- run connection eventloop@@ -176,18 +182,21 @@                                       case event of                                         (InternalReady _ _ _ seshID resumeHost _ _) -> do                                             writeIORef (gatewayHandleSessionId thehandle) seshID-                                            writeIORef (gatewayHandleHostname thehandle) $ resumeHost+                                            writeIORef (gatewayHandleHostname thehandle) resumeHost                                         _ -> writeIORef (startsendingUsers sendablesData) True                                       loop-      Right (Hello _interval) -> do writeChan log ("eventloop - unexpected hello")+      Right (Hello _interval) -> do writeChan log "eventloop - unexpected hello"                                     loop       Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq-                                        writeChan (librarySendables sendablesData) (Heartbeat sq)+                                        sendHeartbeat sendablesData (gatewayHandleHeartbeatTimes thehandle) sq                                         loop       Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart-      Right (Reconnect)      -> pure LoopReconnect-      Right (HeartbeatAck)   -> loop-      Right (ParseError _e)  -> loop  -- getPayload logs the parse error. nothing to do here+      Right Reconnect        -> pure LoopReconnect+      Right HeartbeatAck     -> do+        currTime <- getCurrentTime+        _ <- atomicModifyIORef' (gatewayHandleHeartbeatAckTimes thehandle) (dupe . const currTime)+        loop+      Right (ParseError _)   -> loop  -- getPayload logs the parse error. nothing to do here        Left (CloseRequest code str) -> case code of           -- see Discord and MDN documentation on gateway close event codes@@ -231,14 +240,19 @@                     pure (ParseError (T.pack err))  -- | Infinite loop to send heartbeats to the chan-heartbeat :: SendablesData -> IORef Integer -> IO ()-heartbeat sendablesData seqKey = do+heartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> IORef Integer -> IO ()+heartbeat sendablesData sendTimes seqKey = do   threadDelay (3 * 10^(6 :: Int))   forever $ do     num <- readIORef seqKey-    writeChan (librarySendables sendablesData) (Heartbeat num)+    sendHeartbeat sendablesData sendTimes num     threadDelay (fromInteger (heartbeatInterval sendablesData * 1000)) +sendHeartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO ()+sendHeartbeat sendablesData sendTimes seqKey = do+  currTime <- getCurrentTime+  _ <- atomicModifyIORef' sendTimes (dupe . (currTime,) . fst)+  writeChan (librarySendables sendablesData) (Heartbeat seqKey)  -- | Infinite loop to send library/user events to discord with the actual websocket connection sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO ()@@ -249,7 +263,6 @@       threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double)    -- payload :: Either GatewaySendableInternal GatewaySendable       payload <- race nextLibrary nextUser-   -- writeChan _log ("gateway - sending " <> TE.decodeUtf8 (BL.toStrict (either encode encode payload)))       sendTextData conn (either encode encode payload)       sendLoop @@ -264,4 +277,5 @@                 then readChan (gatewayHandleUserSendables ghandle)                 else threadDelay (4 * (10^(6::Int))) >> nextUser -+dupe :: a -> (a, a)+dupe a = (a, a)

@@ -177,10 +177,11 @@ -- | Options for `ModifyGuildRole` data ModifyGuildRoleOpts = ModifyGuildRoleOpts   { modifyGuildRoleOptsName            :: Maybe T.Text-  , modifyGuildRoleOptsPermissions     :: Maybe T.Text+  , modifyGuildRoleOptsPermissions     :: Maybe RolePermissions   , modifyGuildRoleOptsColor           :: Maybe DiscordColor   , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool   , modifyGuildRoleOptsMentionable     :: Maybe Bool+  , modifyGuildRoleOptsIcon            :: Maybe T.Text   } deriving (Show, Read, Eq, Ord)  instance ToJSON ModifyGuildRoleOpts where@@ -189,7 +190,8 @@                         "permissions" .=? modifyGuildRoleOptsPermissions,                         "color" .=? modifyGuildRoleOptsColor,                         "hoist" .=? modifyGuildRoleOptsSeparateSidebar,-                        "mentionable" .=? modifyGuildRoleOptsMentionable]+                        "mentionable" .=? modifyGuildRoleOptsMentionable,+                        "icon" .=? modifyGuildRoleOptsIcon]  -- | Options for `AddGuildMember` data AddGuildMemberOpts = AddGuildMemberOpts

@@ -0,0 +1,73 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides actions for Scheduled Event API+module Discord.Internal.Rest.ScheduledEvents+    ( ScheduledEventRequest(..)+    ) where+import           Data.Aeson                     ( ToJSON(toJSON) )+import           Discord.Internal.Rest.Prelude  ( JsonRequest(..)+                                                , Request+                                                    ( jsonRequest+                                                    , majorRoute+                                                    )+                                                , baseUrl+                                                )+import           Discord.Internal.Types.Prelude ( GuildId+                                                , ScheduledEventId+                                                )+import           Discord.Internal.Types.ScheduledEvents+                                                ( CreateScheduledEventData+                                                , ModifyScheduledEventData+                                                , ScheduledEvent+                                                , ScheduledEventUser+                                                )+import qualified Network.HTTP.Req              as R+import           Network.HTTP.Req               ( (/:), (/~) )++-- | Data constructor for requests.+-- See <https://discord.com/developers/docs/resources/guild-scheduled-event>+data ScheduledEventRequest a where+  -- | Gets all the Scheduled Events of a Guild+  ListScheduledEvents    ::GuildId+                         -> ScheduledEventRequest [ScheduledEvent]+  -- | Creates a new ScheduledEvent+  CreateScheduledEvent   ::GuildId+                         -> CreateScheduledEventData+                         -> ScheduledEventRequest ScheduledEvent+  -- | Gets the information about an Event+  GetScheduledEvent      ::GuildId+                         -> ScheduledEventId+                         -> ScheduledEventRequest ScheduledEvent+  -- | Modifies a Scheduled Event's information+  ModifyScheduledEvent   ::GuildId+                         -> ScheduledEventId+                         -> ModifyScheduledEventData+                         -> ScheduledEventRequest ScheduledEvent+  -- | Delete a ScheduledEvent+  DeleteScheduledEvent   ::GuildId+                         -> ScheduledEventId+                         -> ScheduledEventRequest ()+  -- | Gets the Users that subscribed to the event+  GetScheduledEventUsers ::GuildId+                         -> ScheduledEventId+                         -> ScheduledEventRequest [ScheduledEventUser]++sevEndpoint :: GuildId -> R.Url 'R.Https+sevEndpoint gid = baseUrl /: "guilds" /~ gid /: "scheduled-events"++instance Request (ScheduledEventRequest a) where+    majorRoute = const "scheduledEvent"+    jsonRequest rq = case rq of+        ListScheduledEvents gid  -> Get (sevEndpoint gid) mempty+        GetScheduledEvent gid ev -> Get (sevEndpoint gid /~ ev) mempty+        CreateScheduledEvent gid ev ->+            Post (sevEndpoint gid) (pure $ R.ReqBodyJson $ toJSON ev) mempty+        ModifyScheduledEvent gid evi ev -> Patch+            (sevEndpoint gid /~ evi)+            (pure $ R.ReqBodyJson $ toJSON ev)+            mempty+        DeleteScheduledEvent gid evi -> Delete (sevEndpoint gid /~ evi) mempty+        GetScheduledEventUsers gid evi ->+            Get (sevEndpoint gid /~ evi /: "users") mempty

@@ -10,6 +10,7 @@     module Discord.Internal.Types.Embed,     module Discord.Internal.Types.Components,     module Discord.Internal.Types.Emoji,+    module Discord.Internal.Types.RolePermissions,     module Data.Aeson,     module Data.Time.Clock,     userFacingEvent,@@ -28,6 +29,7 @@ import Discord.Internal.Types.Guild import Discord.Internal.Types.Prelude import Discord.Internal.Types.User+import Discord.Internal.Types.RolePermissions  -- | Converts an internal event to its user facing counterpart userFacingEvent :: EventInternalParse -> Event@@ -43,7 +45,7 @@   InternalThreadListSync a -> ThreadListSync a   InternalThreadMembersUpdate a -> ThreadMembersUpdate a   InternalChannelPinsUpdate a b -> ChannelPinsUpdate a b-  InternalGuildCreate a -> GuildCreate a+  InternalGuildCreate a b -> GuildCreate a b   InternalGuildUpdate a -> GuildUpdate a   InternalGuildDelete a -> GuildDelete a   InternalGuildBanAdd a b -> GuildBanAdd a b

@@ -21,7 +21,7 @@     EditApplicationCommand (..),     defaultEditApplicationCommand,     Choice (..),-    ApplicationCommandChannelType (..),+    ChannelTypeOption (..),     GuildApplicationCommandPermissions (..),     ApplicationCommandPermissions (..),     Number,@@ -33,13 +33,15 @@  import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Number, Object), object, withArray, withObject, (.!=), (.:), (.:!), (.:?)) import Data.Aeson.Types (Pair, Parser)-import Data.Data (Data) import Data.Foldable (Foldable (toList)) import Data.Scientific (Scientific)-import qualified Data.Text as T-import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, InternalDiscordEnum (..), Snowflake, discordTypeParseJSON, objectFromMaybes, (.==), (.=?))+import Data.Char (isLower, isNumber)+import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, Snowflake, objectFromMaybes, (.==), (.=?)) import Data.Map.Strict (Map)+import Discord.Internal.Types.Channel ( ChannelTypeOption(..) ) +import qualified Data.Text as T+ type Number = Scientific  -- | The structure for an application command.@@ -324,7 +326,7 @@         -- | Whether this option is required         optionValueRequired :: Bool,         -- | What type of channel can be put in here-        optionValueChannelTypes :: Maybe [ApplicationCommandChannelType]+        optionValueChannelTypes :: Maybe [ChannelTypeOption]       }   | OptionValueRole       { -- | The name of the value@@ -561,10 +563,10 @@       ]  nameIsValid :: Bool -> T.Text -> Bool-nameIsValid isChatInput name = l >= 1 && l <= 32 && isChatInput <= T.all (`elem` validChars) name+nameIsValid isChatInput name = l >= 1 && l <= 32 && isChatInput <= T.all validChar name   where     l = T.length name-    validChars = '-' : ['a' .. 'z']+    validChar c = c == '-' || c == '_' || isLower c || isNumber c  -- | Create the basics for a chat input (slash command). Use record overwriting -- to enter the other values. The name needs to be all lower case letters, and@@ -699,55 +701,6 @@ choiceOrAutocompleteToJSON :: (ToJSON a) => AutocompleteOrChoice a -> Pair choiceOrAutocompleteToJSON (Left b) = ("autocomplete", toJSON b) choiceOrAutocompleteToJSON (Right cs) = ("choices", toJSON cs)---- | The different channel types.------ https://discord.com/developers/docs/resources/channel#channel-object-channel-types-data ApplicationCommandChannelType-  = -- | A text channel in a server.-    ApplicationCommandChannelTypeGuildText-  | -- | A direct message between users.-    ApplicationCommandChannelTypeDM-  | -- | A voice channel in a server.-    ApplicationCommandChannelTypeGuildVoice-  | -- | A direct message between multiple users.-    ApplicationCommandChannelTypeGroupDM-  | -- | An organizational category that contains up to 50 channels.-    ApplicationCommandChannelTypeGuildCategory-  | -- | A channel that users can follow and crosspost into their own server.-    ApplicationCommandChannelTypeGuildNews-  | -- | A channel in which game developers can sell their game on discord.-    ApplicationCommandChannelTypeGuildStore-  | -- | A temporary sub-channel within a guild_news channel.-    ApplicationCommandChannelTypeGuildNewsThread-  | -- | A temporary sub-channel within a guild_text channel.-    ApplicationCommandChannelTypeGuildPublicThread-  | -- | A temporary sub-channel within a GUILD_TEXT channel that is only-    -- viewable by those invited and those with the MANAGE_THREADS permission-    ApplicationCommandChannelTypeGuildPrivateThread-  | -- | A voice channel for hosting events with an audience.-    ApplicationCommandChannelTypeGuildStageVoice-  deriving (Show, Read, Data, Eq)--instance InternalDiscordEnum ApplicationCommandChannelType where-  discordTypeStartValue = ApplicationCommandChannelTypeGuildText-  fromDiscordType ApplicationCommandChannelTypeGuildText = 0-  fromDiscordType ApplicationCommandChannelTypeDM = 1-  fromDiscordType ApplicationCommandChannelTypeGuildVoice = 2-  fromDiscordType ApplicationCommandChannelTypeGroupDM = 3-  fromDiscordType ApplicationCommandChannelTypeGuildCategory = 4-  fromDiscordType ApplicationCommandChannelTypeGuildNews = 5-  fromDiscordType ApplicationCommandChannelTypeGuildStore = 6-  fromDiscordType ApplicationCommandChannelTypeGuildNewsThread = 10-  fromDiscordType ApplicationCommandChannelTypeGuildPublicThread = 11-  fromDiscordType ApplicationCommandChannelTypeGuildPrivateThread = 12-  fromDiscordType ApplicationCommandChannelTypeGuildStageVoice = 13--instance ToJSON ApplicationCommandChannelType where-  toJSON = toJSON . fromDiscordType--instance FromJSON ApplicationCommandChannelType where-  parseJSON = discordTypeParseJSON "ApplicationCommandChannelType"  data GuildApplicationCommandPermissions = GuildApplicationCommandPermissions   { -- | The id of the command.

@@ -3,8 +3,30 @@ {-# LANGUAGE DeriveDataTypeable #-}  -- | Data structures pertaining to Discord Channels-module Discord.Internal.Types.Channel where+module Discord.Internal.Types.Channel (+    Channel (..)+  , channelIsInGuild+  , Overwrite (..)+  , ThreadMetadata (..)+  , ThreadMember (..)+  , ThreadListSyncFields (..)+  , ThreadMembersUpdateFields (..)+  , Message (..)+  , AllowedMentions (..)+  , MessageReaction (..)+  , Attachment (..)+  , Nonce (..)+  , MessageReference (..)+  , MessageType (..)+  , MessageActivity (..)+  , MessageActivityType (..)+  , MessageFlag (..)+  , MessageFlags (..)+  , MessageInteraction (..) +  , ChannelTypeOption (..)+  ) where+ import Control.Applicative (empty) import Data.Aeson import Data.Aeson.Types (Parser)@@ -848,7 +870,6 @@               , "name" .== messageInteractionName               , "user" .== messageInteractionUser               ]-  instance FromJSON MessageInteraction where   parseJSON = withObject "MessageInteraction" $ \o ->

@@ -14,6 +14,7 @@     mkButton,     SelectMenu (..),     mkSelectMenu,+    SelectMenuData (..),     SelectOption (..),     mkSelectOption,     TextInput (..),@@ -27,7 +28,7 @@ import Data.Scientific (Scientific) import qualified Data.Text as T import Discord.Internal.Types.Emoji (Emoji)-import Discord.Internal.Types.Prelude (objectFromMaybes, (.==), (.=?))+import Discord.Internal.Types.Prelude (objectFromMaybes, (.==), (.=?), ChannelTypeOption)  -- | Container for other message Components data ActionRow = ActionRowButtons [Button] | ActionRowSelectMenu SelectMenu@@ -52,8 +53,8 @@                         t' <- v .: "type" :: Parser Int                         case t' of                           2 -> ActionRowButtons <$> mapM parseJSON a'-                          3 -> ActionRowSelectMenu <$> parseJSON c-                          _ -> fail $ "unknown component type: " ++ show t+                          _ | t' `elem` [3, 5, 6, 7, 8] -> ActionRowSelectMenu <$> parseJSON c+                          _ -> fail $ "unknown component type: " ++ show t'                     )                     c             _ -> fail $ "expected action row type (1), got: " ++ show t@@ -183,8 +184,8 @@     selectMenuCustomId :: T.Text,     -- | Whether the select menu is disabled     selectMenuDisabled :: Bool,-    -- | What options are in this select menu (up to 25)-    selectMenuOptions :: [SelectOption],+    -- | What type this select menu is, and the data it can hold+    selectMenuData :: SelectMenuData,     -- | Placeholder text if nothing is selected     selectMenuPlaceholder :: Maybe T.Text,     -- | Minimum number of values to select (def 1, min 0, max 25)@@ -197,38 +198,58 @@ -- | Takes the custom id and the options of the select menu that is to be -- generated. mkSelectMenu :: T.Text -> [SelectOption] -> SelectMenu-mkSelectMenu customId sos = SelectMenu customId False sos Nothing Nothing Nothing+mkSelectMenu customId sos = SelectMenu customId False (SelectMenuDataText sos) Nothing Nothing Nothing  instance FromJSON SelectMenu where   parseJSON =     withObject       "SelectMenu"-      ( \v ->+      $ \v ->           do-            t <- v .: "type" :: Parser Int-            case t of-              3 ->                 SelectMenu                   <$> v .: "custom_id"                   <*> v .:? "disabled" .!= False-                  <*> v .: "options"+                  <*> parseJSON (Object v)                   <*> v .:? "placeholder"                   <*> v .:? "min_values"                   <*> v .:? "max_values"-              _ -> fail "expected select menu type, got different component"-      )+        instance ToJSON SelectMenu where   toJSON SelectMenu {..} =-    objectFromMaybes-      [ "type" .== Number 3,-        "custom_id" .== selectMenuCustomId,+    objectFromMaybes $+      [ "custom_id" .== selectMenuCustomId,         "disabled" .== selectMenuDisabled,-        "options" .== selectMenuOptions,         "placeholder" .=? selectMenuPlaceholder,         "min_values" .=? selectMenuMinValues,         "max_values" .=? selectMenuMaxValues-      ]+      ] <> case selectMenuData of+            SelectMenuDataText sos -> ["type" .== Number 3, "options" .== sos]+            SelectMenuDataUser -> ["type" .== Number 5]+            SelectMenuDataRole -> ["type" .== Number 6]+            SelectMenuDataMentionable -> ["type" .== Number 7]+            SelectMenuDataChannels ctos -> ["type" .== Number 8, "channel_types" .== ctos]++data SelectMenuData = +    SelectMenuDataText [SelectOption] -- ^ Text options+  | SelectMenuDataUser -- ^ Users+  | SelectMenuDataRole -- ^ Roles+  | SelectMenuDataMentionable -- ^ Anything mentionable (users and roles)+  | SelectMenuDataChannels [ChannelTypeOption] -- ^ Channels (of certain types)+  deriving (Show, Read, Eq, Ord)++instance FromJSON SelectMenuData where+  parseJSON =+    withObject "SelectMenuData" $ \v ->+      do+        t <- v .: "type"+        case t::Int of+          3 -> SelectMenuDataText <$> v .: "options"+          5 -> pure SelectMenuDataUser+          6 -> pure SelectMenuDataRole+          7 -> pure SelectMenuDataMentionable+          8 -> SelectMenuDataChannels <$> v .: "channel_types"+          _ -> fail ("unknown select menu data type: " <> show t)  -- | A single option in a select menu. data SelectOption = SelectOption

@@ -20,6 +20,7 @@ import Discord.Internal.Types.User (User, GuildMember) import Discord.Internal.Types.Interactions (Interaction) import Discord.Internal.Types.Emoji (Emoji)+import Discord.Internal.Types.ScheduledEvents (ScheduledEvent)   -- | Represents possible events sent by discord. Detailed information can be found at <https://discord.com/developers/docs/topics/gateway>.@@ -47,7 +48,7 @@   -- | message was pinned or unpinned   | ChannelPinsUpdate          ChannelId (Maybe UTCTime)   -- | lazy-load for unavailable guild, guild became available, or user joined a new guild-  | GuildCreate                Guild+  | GuildCreate                Guild GuildCreateData   -- | guild was updated   | GuildUpdate                Guild   -- | guild became unavailable, or user left/was removed from a guild@@ -119,7 +120,7 @@   | InternalThreadListSync             ThreadListSyncFields    | InternalThreadMembersUpdate        ThreadMembersUpdateFields    | InternalChannelPinsUpdate          ChannelId (Maybe UTCTime)-  | InternalGuildCreate                Guild+  | InternalGuildCreate                Guild GuildCreateData   | InternalGuildUpdate                Guild   | InternalGuildDelete                GuildUnavailable   | InternalGuildBanAdd                GuildId User@@ -159,6 +160,32 @@ instance FromJSON PartialApplication where   parseJSON = withObject "PartialApplication" (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") +data GuildCreateData = GuildCreateData+  { guildCreateJoinedAt :: !UTCTime+  , guildCreateLarge :: !Bool+  , guildCreateUnavailable :: !(Maybe Bool)+  , guildCreateMemberCount :: !Int+  -- , guildCreateVoiceStates+  , guildCreateMembers :: ![GuildMember]+  , guildCreateChannels :: ![Channel]+  , guildCreateThreads :: ![Channel]+  , guildCreatePresences :: ![PresenceInfo]+  -- , guildStageInstances :: [StageI]+  , guildCreateScheduledEvents :: ![ScheduledEvent]+  } deriving (Show, Eq, Read)++instance FromJSON GuildCreateData where+  parseJSON = withObject "GuildCreateData" $ \o ->+    GuildCreateData <$> o .:  "joined_at"+                    <*> o .:  "large"+                    <*> o .:? "unavailable"+                    <*> o .:  "member_count"+                    <*> o .:  "members"+                    <*> o .:  "channels"+                    <*> o .:  "threads"+                    <*> o .:  "presences"+                    <*> o .:  "guild_scheduled_events"+ -- | Structure containing information about a reaction data ReactionInfo = ReactionInfo   { reactionUserId    :: UserId -- ^ User who reacted@@ -218,8 +245,8 @@ -- the hostname portion of the URL that we can connect to. extractHostname :: String -> HostName extractHostname ('w':'s':'s':':':'/':'/':rest) = extractHostname rest-extractHostname ('/':[]) = []-extractHostname (a:b) = a:(extractHostname b)+extractHostname "/" = []+extractHostname (a:b) = a:extractHostname b extractHostname [] = []  -- | Parse an event from name and JSON data@@ -248,7 +275,7 @@                                       stamp <- o .:? "last_pin_timestamp"                                       let utc = stamp >>= parseISO8601                                       pure (InternalChannelPinsUpdate id utc)-    "GUILD_CREATE"              -> InternalGuildCreate               <$> reparse o+    "GUILD_CREATE"              -> InternalGuildCreate <$> reparse o <*> reparse o     "GUILD_UPDATE"              -> InternalGuildUpdate               <$> reparse o     "GUILD_DELETE"              -> InternalGuildDelete               <$> reparse o     "GUILD_BAN_ADD"             -> InternalGuildBanAdd    <$> o .: "guild_id" <*> o .: "user"

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-}  -- | Types relating to Discord Guilds (servers)@@ -14,18 +13,16 @@  import Discord.Internal.Types.Prelude import Discord.Internal.Types.Color (DiscordColor)-import Discord.Internal.Types.Channel (Channel)-import Discord.Internal.Types.User (User, GuildMember)+import Discord.Internal.Types.User (User) import Discord.Internal.Types.Emoji (Emoji, StickerItem)--+import Data.List  -- | Guilds in Discord represent a collection of users and channels into an isolated --   "Server" -- -- https://discord.com/developers/docs/resources/guild#guild-object data Guild = Guild-      { guildId                   :: GuildId              -- ^ Gulid id+      { guildId                   :: GuildId              -- ^ Guild id       , guildName                 :: T.Text               -- ^ Guild name (2 - 100 chars)       , guildIcon                 :: Maybe T.Text         -- ^ Icon hash       , guildIconHash             :: Maybe T.Text         -- ^ Icon hash, when returned in template object@@ -49,15 +46,6 @@       , guildSystemChannelId      :: Maybe ChannelId      -- ^ Channel where guild notices such as welcome messages and boost events       , guildSystemChannelFlags   :: Integer              -- ^ Flags on the system channel       , guildRulesChannelId       :: Maybe ChannelId      -- ^ Id of channel with rules/guidelines-      , guildJoinedAt             :: Maybe UTCTime        -- ^ When this guild was joined at-      , guildLarge                :: Maybe Bool           -- ^ True if this guild is considered large-      , guildUnavailable          :: Maybe Bool           -- ^ True if the guild is unavailable due to outage-      , guildMemberCount          :: Maybe Integer        -- ^ Total number of members in the guild-      -- voice_states-      , guildMembers              :: Maybe [GuildMember]  -- ^ Users in the guild-      , guildChannels             :: Maybe [Channel]      -- ^ Channels in the guild-      , guildThreads              :: Maybe [Channel]      -- ^ All active threads in the guild that the current user has permission to view-      , guildPresences            :: Maybe [PresenceInfo] -- ^ Presences of the members in the guild       , guildMaxPresences         :: Maybe Integer        -- ^ Maximum number of prescences in the guild       , guildMaxMembers           :: Maybe Integer        -- ^ Maximum number of members in the guild       , guildVanityURL            :: Maybe T.Text         -- ^ Vanity url code for the guild@@ -68,8 +56,8 @@       , guildPreferredLocale      :: T.Text               -- ^ Preferred locale of a community server       , guildPublicUpdatesChannel :: Maybe ChannelId      -- ^ Id of channel where admins and mods get updates       , guildMaxVideoUsers        :: Maybe Integer        -- ^ Maximum number of users in video channel-      , guildApproxMemberCount    :: Maybe Integer        -- ^ Approximate number of members in the guild-      , guildApproxPresenceCount  :: Maybe Integer        -- ^ Approximate number of non-offline members in the guild+      , guildApproxMemberCount    :: Maybe Integer        -- ^ Approximate number of members in the guild (GET /guilds/<id> endpoint when with_counts is true)+      , guildApproxPresenceCount  :: Maybe Integer        -- ^ Approximate number of non-offline members in the guild (GET /guilds/<id> endpoint when with_counts is true)       -- welcome_screen       , guildNSFWLevel            :: Integer              -- ^ Guild NSFW level       -- stage_instances@@ -104,15 +92,6 @@           <*> o .:? "system_channel_id"           <*> o .:  "system_channel_flags"           <*> o .:? "rules_channel_id"-          <*> o .:? "joined_at"-          <*> o .:? "large"-          <*> o .:? "unavailable"-          <*> o .:? "member_count"-          -- voice_states-          <*> o .:? "members"-          <*> o .:? "channels"-          <*> o .:? "threads"-          <*> o .:? "presences"           <*> o .:? "max_presences"           <*> o .:? "max_members"           <*> o .:? "vanity_url_code"@@ -160,7 +139,7 @@ -- -- When setting a bot's activity, only the name, url, and type are sent - and -- it seems that not many types are permitted either.-data Activity = +data Activity =   Activity     { activityName :: T.Text -- ^ Name of activity     , activityType :: ActivityType -- ^ Type of activity@@ -233,7 +212,7 @@  -- | To see what these look like, go to here:  -- https://discord.com/developers/docs/topics/gateway#activity-object-activity-types-data ActivityType = +data ActivityType =     ActivityTypeGame   | ActivityTypeStreaming   | ActivityTypeListening@@ -282,7 +261,7 @@       , roleColor   :: DiscordColor              -- ^ Integer representation of color code       , roleHoist   :: Bool                      -- ^ If the role is pinned in the user listing       , rolePos     :: Integer                   -- ^ Position of this role-      , rolePerms   :: T.Text                    -- ^ Permission bit set+      , rolePerms   :: RolePermissions           -- ^ Permission bit set       , roleManaged :: Bool                      -- ^ Whether this role is managed by an integration       , roleMention :: Bool                      -- ^ Whether this role is mentionable     } deriving (Show, Read, Eq, Ord)@@ -297,6 +276,13 @@          <*> o .: "permissions"          <*> o .: "managed"          <*> o .: "mentionable"+++-- | If there is no such role on the guild return nothing+--   otherwise return the role. Take the head of the list. List should always be one, because the ID is unique+roleIdToRole :: Guild -> RoleId -> Maybe Role+roleIdToRole  g r = find(\x -> roleId x == r) $ guildRoles g+  -- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added data VoiceRegion = VoiceRegion

@@ -240,7 +240,7 @@       { -- | The unique id of the component (up to 100 characters).         componentDataCustomId :: T.Text,         -- | Values for the select menu.-        componentDataValues :: [T.Text]+        componentDataValues :: SelectMenuData       }   deriving (Show, Read, Eq, Ord) @@ -253,11 +253,35 @@           t <- v .: "component_type" :: Parser Int           case t of             2 -> return $ ButtonData cid-            3 ->+            _ | t `elem` [3, 5, 6, 7, 8] ->               SelectMenuData cid-                <$> v .: "values"-            _ -> fail "unknown interaction data component type"+                <$> parseJSON (toJSON v)+            _ -> fail $ "unknown interaction data component type: " <> show t       )++data SelectMenuData+  = SelectMenuDataText [T.Text] -- ^ The values of text chosen options+  | SelectMenuDataUser [UserId] -- ^ The users selected+  | SelectMenuDataRole [RoleId] -- ^ The roles selected+  | SelectMenuDataMentionable [Snowflake] -- ^ The users or roles selected+  | SelectMenuDataChannels [ChannelId] -- ^ The channels selected+  deriving (Show, Read, Eq, Ord)++instance FromJSON SelectMenuData where+  parseJSON =+    withObject+      "SelectMenuData"+      $ \v -> do+          t <- v .: "component_type" :: Parser Int+          let cons :: forall a. FromJSON a => ([a] -> SelectMenuData) -> Parser SelectMenuData+              cons f = f <$> v .: "values"+          case t of+            3 -> cons SelectMenuDataText+            5 -> cons SelectMenuDataUser+            6 -> cons SelectMenuDataRole+            7 -> cons SelectMenuDataMentionable+            8 -> cons SelectMenuDataChannels+            _ -> fail $ "unknown SelectMenuData type: " <> show t  data ApplicationCommandData   = ApplicationCommandDataUser

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE RankNTypes  #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}  -- | Provides base types and utility functions needed for modules in Discord.Internal.Types module Discord.Internal.Types.Prelude@@ -12,6 +13,8 @@    , Snowflake (..)   , snowflakeCreationDate++  , RolePermissions (..)      , DiscordId (..)   , ChannelId@@ -48,6 +51,8 @@   , (.=?)   , AesonKey   , objectFromMaybes++  , ChannelTypeOption (..)   )   where@@ -108,6 +113,26 @@ instance ToHttpApiData Snowflake where   toUrlPiece = T.pack . show +newtype RolePermissions = RolePermissions { getRolePermissions :: Integer } +  deriving (Eq, Ord, Num, Bits, Enum, Real, Integral)++instance Read RolePermissions where+  readsPrec p = fmap (first RolePermissions) . readsPrec p++instance ToJSON RolePermissions where+  toJSON = toJSON . getRolePermissions++-- In v8 and above, all permissions are serialized as strings.+-- See https://discord.com/developers/docs/topics/permissions#permissions.+instance FromJSON RolePermissions where+  parseJSON = withText "RolePermissions" $+      \text -> case readMaybe (T.unpack text) of+              Just perms -> pure $ RolePermissions perms+              Nothing    -> fail "invalid role permissions integer string"++instance Show RolePermissions where+  show = show . getRolePermissions+ newtype DiscordId a = DiscordId { unId :: Snowflake }   deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) @@ -308,3 +333,52 @@   | B.take 4 bs == "RIFF" && B.take 4 (B.drop 8 bs) == "WEBP"   = Just "image/webp"   | otherwise = Nothing++-- | The different channel types. Used for application commands and components.+--+-- https://discord.com/developers/docs/resources/channel#channel-object-channel-types+data ChannelTypeOption+  = -- | A text channel in a server.+    ChannelTypeOptionGuildText+  | -- | A direct message between users.+    ChannelTypeOptionDM+  | -- | A voice channel in a server.+    ChannelTypeOptionGuildVoice+  | -- | A direct message between multiple users.+    ChannelTypeOptionGroupDM+  | -- | An organizational category that contains up to 50 channels.+    ChannelTypeOptionGuildCategory+  | -- | A channel that users can follow and crosspost into their own server.+    ChannelTypeOptionGuildNews+  | -- | A channel in which game developers can sell their game on discord.+    ChannelTypeOptionGuildStore+  | -- | A temporary sub-channel within a guild_news channel.+    ChannelTypeOptionGuildNewsThread+  | -- | A temporary sub-channel within a guild_text channel.+    ChannelTypeOptionGuildPublicThread+  | -- | A temporary sub-channel within a GUILD_TEXT channel that is only+    -- viewable by those invited and those with the MANAGE_THREADS permission+    ChannelTypeOptionGuildPrivateThread+  | -- | A voice channel for hosting events with an audience.+    ChannelTypeOptionGuildStageVoice+  deriving (Show, Read, Data, Eq, Ord)++instance InternalDiscordEnum ChannelTypeOption where+  discordTypeStartValue = ChannelTypeOptionGuildText+  fromDiscordType ChannelTypeOptionGuildText = 0+  fromDiscordType ChannelTypeOptionDM = 1+  fromDiscordType ChannelTypeOptionGuildVoice = 2+  fromDiscordType ChannelTypeOptionGroupDM = 3+  fromDiscordType ChannelTypeOptionGuildCategory = 4+  fromDiscordType ChannelTypeOptionGuildNews = 5+  fromDiscordType ChannelTypeOptionGuildStore = 6+  fromDiscordType ChannelTypeOptionGuildNewsThread = 10+  fromDiscordType ChannelTypeOptionGuildPublicThread = 11+  fromDiscordType ChannelTypeOptionGuildPrivateThread = 12+  fromDiscordType ChannelTypeOptionGuildStageVoice = 13++instance ToJSON ChannelTypeOption where+  toJSON = toJSON . fromDiscordType++instance FromJSON ChannelTypeOption where+  parseJSON = discordTypeParseJSON "ChannelTypeOption"

@@ -0,0 +1,119 @@+module Discord.Internal.Types.RolePermissions+  ( PermissionFlag (..),+    hasRolePermissions,+    hasRolePermission,+    newRolePermissions,+    newRolePermission,+    setRolePermissions,+    setRolePermission,+    clearRolePermissions,+    clearRolePermission,+    hasGuildMemberPermission,+  )+where++import Data.Bits (Bits (complement, shift, (.&.), (.|.)))+import Discord.Internal.Types.Guild+  ( Guild,+    Role (rolePerms),+    roleIdToRole,+  )+import Discord.Internal.Types.Prelude (RolePermissions)+import Discord.Internal.Types.User (GuildMember (memberRoles))++data PermissionFlag+  = CREATE_INSTANT_INVITE+  | KICK_MEMBERS+  | BAN_MEMBERS+  | ADMINISTRATOR+  | MANAGE_CHANNELS+  | MANAGE_GUILD+  | ADD_REACTIONS+  | VIEW_AUDIT_LOG+  | PRIORITY_SPEAKER+  | STREAM+  | VIEW_CHANNEL+  | SEND_MESSAGES+  | SEND_TTS_MESSAGES+  | MANAGE_MESSAGES+  | EMBED_LINKS+  | ATTACH_FILES+  | READ_MESSAGE_HISTORY+  | MENTION_EVERYONE+  | USE_EXTERNAL_EMOJIS+  | VIEW_GUILD_INSIGHT+  | CONNECT+  | SPEAK+  | MUTE_MEMBERS+  | DEAFEN_MEMBERS+  | MOVE_MEMBERS+  | USE_VAD+  | CHANGE_NICKNAME+  | MANAGE_NICKNAMES+  | MANAGE_ROLES+  | MANAGE_WEBHOOKS+  | MANAGE_EMOJIS_AND_STICKERS+  | USE_APPLICATION_COMMANDS+  | REQUEST_TO_SPEAK+  | MANAGE_EVENTS+  | MANAGE_THREADS+  | CREATE_PUBLIC_THREADS+  | CREATE_PRIVATE_THREADS+  | USE_EXTERNAL_STICKERS+  | SEND_MESSAGES_IN_THREADS+  | USE_EMBEDDED_ACTIVITIES+  | MODERATE_MEMBERS+  deriving (Eq, Ord, Enum, Show)++permissionBits :: PermissionFlag -> RolePermissions+permissionBits p = shift 1 (fromEnum p)++-- | Check if a given role has all the permissions+hasRolePermissions :: [PermissionFlag] -> RolePermissions -> Bool+hasRolePermissions permissions rolePermissions = (.&.) combinedPermissions rolePermissions == combinedPermissions+  where+    combinedPermissions = combinePermissions permissions++-- | Check if a given role has the permission+hasRolePermission :: PermissionFlag -> RolePermissions -> Bool+hasRolePermission p r = (.&.) (permissionBits p) r > 0++-- | Replace a users rolePerms+--   with a complete new set of permissions+newRolePermissions :: [PermissionFlag] -> RolePermissions+newRolePermissions = combinePermissions++-- | Get the RolePermissions of a single PermissionFlag+newRolePermission :: PermissionFlag -> RolePermissions+newRolePermission = permissionBits++-- | Update RolePermissions with new permissions+setRolePermissions :: [PermissionFlag] -> RolePermissions -> RolePermissions+setRolePermissions p r = combinePermissions p .|. r++-- | Unset Permissions from RolePermissions+clearRolePermissions :: [PermissionFlag] -> RolePermissions -> RolePermissions+clearRolePermissions p r = (complement . combinePermissions) p .&. r++-- | Set a certain permission flag+--   This method doesn't lose the other already present permissions+setRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions+setRolePermission p = (.|.) (permissionBits p)++-- | Remove a permission from a user by clearing the bit+clearRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions+clearRolePermission p = (.&.) (complement . permissionBits $ p)++combinePermissions :: [PermissionFlag] -> RolePermissions+combinePermissions = foldr ((.|.) . permissionBits) 0++-- | Check if any Role of an GuildMember has the needed permission+--   If the result of roleIdToRole is Nothing, it prepends a "False"+--   Otherwise it checks for the needed permission+hasGuildMemberPermission :: Guild -> GuildMember -> PermissionFlag -> Bool+hasGuildMemberPermission g gm p = go (memberRoles gm)+  where+    go [] = False+    go (x : xs) = case roleIdToRole g x of+      Nothing -> go xs+      Just a -> p `hasRolePermission` rolePerms a || go xs

@@ -93,6 +93,7 @@       , scheduledEventExternalUserCount :: Maybe Integer       , scheduledEventExternalImage :: Maybe ScheduledEventImageHash       }+  deriving (Show, Eq, Read)  instance ToJSON ScheduledEvent where   toJSON ScheduledEventStage {..} = objectFromMaybes

@@ -8,6 +8,7 @@   , module Discord.Internal.Rest.Webhook   , module Discord.Internal.Rest.ApplicationCommands   , module Discord.Internal.Rest.Interactions+  , module Discord.Internal.Rest.ScheduledEvents   ) where  import Discord.Internal.Rest.Channel@@ -19,3 +20,4 @@ import Discord.Internal.Rest.Webhook import Discord.Internal.Rest.ApplicationCommands import Discord.Internal.Rest.Interactions+import Discord.Internal.Rest.ScheduledEvents