calamity 0.1.25.1 → 0.1.26.0

raw patch · 212 files changed

+9652/−9632 lines, 212 filesdep −generic-overridedep −generic-override-aesondep ~polysemy-plugindep ~reqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: generic-override, generic-override-aeson

Dependency ranges changed: polysemy-plugin, req

API changes (from Hackage documentation)

Files

• Calamity.hs +12/−0
• Calamity/Cache/Eff.hs +121/−0
• Calamity/Cache/InMemory.hs +123/−0
• Calamity/Client.hs +44/−0
• Calamity/Client/Client.hs +732/−0
• Calamity/Client/ShardManager.hs +52/−0
• Calamity/Client/Types.hs +354/−0
• Calamity/Commands.hs +78/−0
• Calamity/Commands/AliasType.hs +15/−0
• Calamity/Commands/Check.hs +51/−0
• Calamity/Commands/Command.hs +71/−0
• Calamity/Commands/Command.hs-boot +11/−0
• Calamity/Commands/CommandUtils.hs +212/−0
• Calamity/Commands/Context.hs +42/−0
• Calamity/Commands/Context.hs-boot +10/−0
• Calamity/Commands/Dsl.hs +361/−0
• Calamity/Commands/Error.hs +21/−0
• Calamity/Commands/Group.hs +53/−0
• Calamity/Commands/Handler.hs +24/−0
• Calamity/Commands/Help.hs +193/−0
• Calamity/Commands/ParsePrefix.hs +27/−0
• Calamity/Commands/Parser.hs +360/−0
• Calamity/Commands/Utils.hs +194/−0
• Calamity/Gateway.hs +23/−0
• Calamity/Gateway/DispatchEvents.hs +230/−0
• Calamity/Gateway/Intents.hs +56/−0
• Calamity/Gateway/Shard.hs +355/−0
• Calamity/Gateway/Types.hs +289/−0
• Calamity/HTTP.hs +54/−0
• Calamity/HTTP/AuditLog.hs +47/−0
• Calamity/HTTP/Channel.hs +333/−0
• Calamity/HTTP/Emoji.hs +70/−0
• Calamity/HTTP/Guild.hs +358/−0
• Calamity/HTTP/Internal/Ratelimit.hs +209/−0
• Calamity/HTTP/Internal/Request.hs +145/−0
• Calamity/HTTP/Internal/Route.hs +148/−0
• Calamity/HTTP/Internal/Types.hs +61/−0
• Calamity/HTTP/Invite.hs +32/−0
• Calamity/HTTP/MiscRoutes.hs +25/−0
• Calamity/HTTP/Reason.hs +29/−0
• Calamity/HTTP/User.hs +87/−0
• Calamity/HTTP/Webhook.hs +136/−0
• Calamity/Internal/AesonThings.hs +144/−0
• Calamity/Internal/BoundedStore.hs +84/−0
• Calamity/Internal/ConstructorName.hs +24/−0
• Calamity/Internal/IntColour.hs +29/−0
• Calamity/Internal/LocalWriter.hs +27/−0
• Calamity/Internal/RunIntoIO.hs +24/−0
• Calamity/Internal/SnowflakeMap.hs +237/−0
• Calamity/Internal/Updateable.hs +98/−0
• Calamity/Internal/Utils.hs +152/−0
• Calamity/Metrics/Eff.hs +62/−0
• Calamity/Metrics/Internal.hs +20/−0
• Calamity/Metrics/Noop.hs +20/−0
• Calamity/Types.hs +30/−0
• Calamity/Types/LogEff.hs +16/−0
• Calamity/Types/Model.hs +13/−0
• Calamity/Types/Model/Channel.hs +68/−0
• Calamity/Types/Model/Channel.hs-boot +7/−0
• Calamity/Types/Model/Channel/Attachment.hs +50/−0
• Calamity/Types/Model/Channel/ChannelType.hs +34/−0
• Calamity/Types/Model/Channel/DM.hs +35/−0
• Calamity/Types/Model/Channel/Embed.hs +142/−0
• Calamity/Types/Model/Channel/Group.hs +36/−0
• Calamity/Types/Model/Channel/Guild.hs +92/−0
• Calamity/Types/Model/Channel/Guild/Category.hs +30/−0
• Calamity/Types/Model/Channel/Guild/Category.hs-boot +8/−0
• Calamity/Types/Model/Channel/Guild/Text.hs +44/−0
• Calamity/Types/Model/Channel/Guild/Voice.hs +34/−0
• Calamity/Types/Model/Channel/Message.hs +97/−0
• Calamity/Types/Model/Channel/Message.hs-boot +14/−0
• Calamity/Types/Model/Channel/Reaction.hs +32/−0
• Calamity/Types/Model/Channel/UpdatedMessage.hs +46/−0
• Calamity/Types/Model/Channel/Webhook.hs +32/−0
• Calamity/Types/Model/Guild.hs +23/−0
• Calamity/Types/Model/Guild/AuditLog.hs +228/−0
• Calamity/Types/Model/Guild/Ban.hs +26/−0
• Calamity/Types/Model/Guild/Emoji.hs +102/−0
• Calamity/Types/Model/Guild/Guild.hs +162/−0
• Calamity/Types/Model/Guild/Guild.hs-boot +14/−0
• Calamity/Types/Model/Guild/Invite.hs +31/−0
• Calamity/Types/Model/Guild/Member.hs +59/−0
• Calamity/Types/Model/Guild/Member.hs-boot +8/−0
• Calamity/Types/Model/Guild/Overwrite.hs +25/−0
• Calamity/Types/Model/Guild/Permissions.hs +100/−0
• Calamity/Types/Model/Guild/Role.hs +40/−0
• Calamity/Types/Model/Guild/UnavailableGuild.hs +23/−0
• Calamity/Types/Model/Presence.hs +7/−0
• Calamity/Types/Model/Presence/Activity.hs +131/−0
• Calamity/Types/Model/Presence/Presence.hs +43/−0
• Calamity/Types/Model/User.hs +73/−0
• Calamity/Types/Model/Voice.hs +7/−0
• Calamity/Types/Model/Voice/VoiceRegion.hs +26/−0
• Calamity/Types/Model/Voice/VoiceState.hs +31/−0
• Calamity/Types/Partial.hs +5/−0
• Calamity/Types/Snowflake.hs +85/−0
• Calamity/Types/Tellable.hs +155/−0
• Calamity/Types/Token.hs +26/−0
• Calamity/Types/UnixTimestamp.hs +68/−0
• Calamity/Types/Upgradeable.hs +140/−0
• Calamity/Utils.hs +9/−0
• Calamity/Utils/Colour.hs +18/−0
• Calamity/Utils/Message.hs +197/−0
• Calamity/Utils/Permissions.hs +118/−0
• ChangeLog.md +7/−0
• README.md +26/−5
• cabal.project +0/−7
• calamity.cabal +10/−13
• src/Calamity.hs +0/−12
• src/Calamity/Cache/Eff.hs +0/−121
• src/Calamity/Cache/InMemory.hs +0/−123
• src/Calamity/Client.hs +0/−44
• src/Calamity/Client/Client.hs +0/−731
• src/Calamity/Client/ShardManager.hs +0/−52
• src/Calamity/Client/Types.hs +0/−354
• src/Calamity/Commands.hs +0/−78
• src/Calamity/Commands/AliasType.hs +0/−15
• src/Calamity/Commands/Check.hs +0/−51
• src/Calamity/Commands/Command.hs +0/−71
• src/Calamity/Commands/Command.hs-boot +0/−11
• src/Calamity/Commands/CommandUtils.hs +0/−212
• src/Calamity/Commands/Context.hs +0/−42
• src/Calamity/Commands/Context.hs-boot +0/−10
• src/Calamity/Commands/Dsl.hs +0/−361
• src/Calamity/Commands/Error.hs +0/−21
• src/Calamity/Commands/Group.hs +0/−53
• src/Calamity/Commands/Handler.hs +0/−24
• src/Calamity/Commands/Help.hs +0/−193
• src/Calamity/Commands/ParsePrefix.hs +0/−27
• src/Calamity/Commands/Parser.hs +0/−360
• src/Calamity/Commands/Utils.hs +0/−194
• src/Calamity/Gateway.hs +0/−23
• src/Calamity/Gateway/DispatchEvents.hs +0/−230
• src/Calamity/Gateway/Intents.hs +0/−56
• src/Calamity/Gateway/Shard.hs +0/−350
• src/Calamity/Gateway/Types.hs +0/−289
• src/Calamity/HTTP.hs +0/−54
• src/Calamity/HTTP/AuditLog.hs +0/−47
• src/Calamity/HTTP/Channel.hs +0/−331
• src/Calamity/HTTP/Emoji.hs +0/−70
• src/Calamity/HTTP/Guild.hs +0/−358
• src/Calamity/HTTP/Internal/Ratelimit.hs +0/−209
• src/Calamity/HTTP/Internal/Request.hs +0/−145
• src/Calamity/HTTP/Internal/Route.hs +0/−148
• src/Calamity/HTTP/Internal/Types.hs +0/−61
• src/Calamity/HTTP/Invite.hs +0/−32
• src/Calamity/HTTP/MiscRoutes.hs +0/−25
• src/Calamity/HTTP/Reason.hs +0/−29
• src/Calamity/HTTP/User.hs +0/−87
• src/Calamity/HTTP/Webhook.hs +0/−136
• src/Calamity/Internal/AesonThings.hs +0/−144
• src/Calamity/Internal/BoundedStore.hs +0/−84
• src/Calamity/Internal/ConstructorName.hs +0/−24
• src/Calamity/Internal/IntColour.hs +0/−29
• src/Calamity/Internal/LocalWriter.hs +0/−27
• src/Calamity/Internal/RunIntoIO.hs +0/−24
• src/Calamity/Internal/SnowflakeMap.hs +0/−237
• src/Calamity/Internal/Updateable.hs +0/−98
• src/Calamity/Internal/Utils.hs +0/−152
• src/Calamity/Metrics/Eff.hs +0/−62
• src/Calamity/Metrics/Internal.hs +0/−20
• src/Calamity/Metrics/Noop.hs +0/−20
• src/Calamity/Types.hs +0/−30
• src/Calamity/Types/LogEff.hs +0/−16
• src/Calamity/Types/Model.hs +0/−13
• src/Calamity/Types/Model/Channel.hs +0/−68
• src/Calamity/Types/Model/Channel.hs-boot +0/−7
• src/Calamity/Types/Model/Channel/Attachment.hs +0/−50
• src/Calamity/Types/Model/Channel/ChannelType.hs +0/−34
• src/Calamity/Types/Model/Channel/DM.hs +0/−35
• src/Calamity/Types/Model/Channel/Embed.hs +0/−142
• src/Calamity/Types/Model/Channel/Group.hs +0/−36
• src/Calamity/Types/Model/Channel/Guild.hs +0/−92
• src/Calamity/Types/Model/Channel/Guild/Category.hs +0/−30
• src/Calamity/Types/Model/Channel/Guild/Category.hs-boot +0/−8
• src/Calamity/Types/Model/Channel/Guild/Text.hs +0/−44
• src/Calamity/Types/Model/Channel/Guild/Voice.hs +0/−34
• src/Calamity/Types/Model/Channel/Message.hs +0/−97
• src/Calamity/Types/Model/Channel/Message.hs-boot +0/−14
• src/Calamity/Types/Model/Channel/Reaction.hs +0/−32
• src/Calamity/Types/Model/Channel/UpdatedMessage.hs +0/−46
• src/Calamity/Types/Model/Channel/Webhook.hs +0/−32
• src/Calamity/Types/Model/Guild.hs +0/−23
• src/Calamity/Types/Model/Guild/AuditLog.hs +0/−228
• src/Calamity/Types/Model/Guild/Ban.hs +0/−26
• src/Calamity/Types/Model/Guild/Emoji.hs +0/−102
• src/Calamity/Types/Model/Guild/Guild.hs +0/−162
• src/Calamity/Types/Model/Guild/Guild.hs-boot +0/−14
• src/Calamity/Types/Model/Guild/Invite.hs +0/−31
• src/Calamity/Types/Model/Guild/Member.hs +0/−59
• src/Calamity/Types/Model/Guild/Member.hs-boot +0/−8
• src/Calamity/Types/Model/Guild/Overwrite.hs +0/−25
• src/Calamity/Types/Model/Guild/Permissions.hs +0/−100
• src/Calamity/Types/Model/Guild/Role.hs +0/−40
• src/Calamity/Types/Model/Guild/UnavailableGuild.hs +0/−23
• src/Calamity/Types/Model/Presence.hs +0/−7
• src/Calamity/Types/Model/Presence/Activity.hs +0/−131
• src/Calamity/Types/Model/Presence/Presence.hs +0/−49
• src/Calamity/Types/Model/User.hs +0/−73
• src/Calamity/Types/Model/Voice.hs +0/−7
• src/Calamity/Types/Model/Voice/VoiceRegion.hs +0/−26
• src/Calamity/Types/Model/Voice/VoiceState.hs +0/−31
• src/Calamity/Types/Partial.hs +0/−5
• src/Calamity/Types/Snowflake.hs +0/−85
• src/Calamity/Types/Tellable.hs +0/−155
• src/Calamity/Types/Token.hs +0/−26
• src/Calamity/Types/UnixTimestamp.hs +0/−68
• src/Calamity/Types/Upgradeable.hs +0/−140
• src/Calamity/Utils.hs +0/−9
• src/Calamity/Utils/Colour.hs +0/−18
• src/Calamity/Utils/Message.hs +0/−197
• src/Calamity/Utils/Permissions.hs +0/−118

@@ -0,0 +1,12 @@+module Calamity+    ( module Calamity.Client+    , module Calamity.HTTP+    , module Calamity.Types+    , module Calamity.Utils+    , module Calamity.Gateway.Intents ) where++import           Calamity.Client+import           Calamity.Gateway.Intents+import           Calamity.HTTP+import           Calamity.Types+import           Calamity.Utils

@@ -0,0 +1,121 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Effect for handling the cache+module Calamity.Cache.Eff+    ( CacheEff(..)+    , setBotUser+    , updateBotUser+    , getBotUser+    , setGuild+    , updateGuild+    , getGuild+    , getGuildChannel+    , getGuilds+    , delGuild+    , setDM+    , updateDM+    , getDM+    , getDMs+    , delDM+      -- , setGuildChannel+      -- , getGuildChannel+      -- , delGuildChannel+    , setUser+    , updateUser+    , getUser+    , getUsers+    , delUser+    , setUnavailableGuild+    , isUnavailableGuild+    , getUnavailableGuilds+    , delUnavailableGuild+    , setMessage+    , updateMessage+    , getMessage+    , getMessages+    , delMessage ) where++import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Polysemy+import qualified Polysemy                     as P++data CacheEff m a where+  -- | Set the 'User' representing the bot itself+  SetBotUser :: User -> CacheEff m ()+  -- | Get the 'User' representing the bot itself+  GetBotUser :: CacheEff m (Maybe User)++  -- | Set or Update a 'Guild' in the cache+  SetGuild :: Guild -> CacheEff m ()+  -- | Get a 'Guild' from the cache+  GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild)+  -- | Get a 'GuildChannel' from the cache+  GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel)+  -- | Get all 'Guild's from the cache+  GetGuilds :: CacheEff m [Guild]+  -- | Delete a 'Guild' from the cache+  DelGuild :: Snowflake Guild -> CacheEff m ()++  -- | Set or Update a 'DMChannel' in the cache+  SetDM :: DMChannel -> CacheEff m ()+  -- | Get a 'DMChannel' from the cache+  GetDM :: Snowflake DMChannel -> CacheEff m (Maybe DMChannel)+  -- | Get all 'DMChannel's from the cache+  GetDMs :: CacheEff m [DMChannel]+  -- | Delete a 'DMChannel' from the cache+  DelDM :: Snowflake DMChannel -> CacheEff m ()++  -- -- | Set or Update a 'GuildChannel' in the cache+  -- SetGuildChannel :: GuildChannel -> CacheEff m ()+  -- -- | Get a 'GuildChannel' from the cache+  -- GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel)+  -- -- | Delete a 'GuildChannel' from the cache+  -- DelGuildChannel :: Snowflake GuildChannel -> CacheEff m ()+  -- | Set or Update a 'User' in the cache+  SetUser :: User -> CacheEff m ()+  -- | Get a 'User' from the cache+  GetUser :: Snowflake User -> CacheEff m (Maybe User)+  -- | Get all 'User's from the cache+  GetUsers :: CacheEff m [User]+  -- | Delete a 'User' from the cache+  DelUser :: Snowflake User -> CacheEff m ()++  -- | Flag a 'Guild' as unavailable+  SetUnavailableGuild :: Snowflake Guild -> CacheEff m ()+  -- | Test if a 'Guild' is flagged as unavailable+  IsUnavailableGuild :: Snowflake Guild -> CacheEff m Bool+  -- | Get all 'UnavailableGuild's from the cache+  GetUnavailableGuilds :: CacheEff m [Snowflake Guild]+  -- | Unflag a 'Guild' from being unavailable+  DelUnavailableGuild :: Snowflake Guild -> CacheEff m ()++  -- | Add or Update a 'Message' in the cache+  SetMessage :: Message -> CacheEff m ()+  -- | Get a 'Message' from the cache+  GetMessage :: Snowflake Message -> CacheEff m (Maybe Message)+  -- | Get all 'Message's from the cache+  GetMessages :: CacheEff m [Message]+  -- | Delete a 'Message' from the cache+  DelMessage :: Snowflake Message -> CacheEff m ()++makeSem ''CacheEff++updateBotUser :: P.Member CacheEff r => (User -> User) -> Sem r ()+updateBotUser f = getBotUser >>= flip whenJust (setBotUser . f)++updateGuild :: P.Member CacheEff r => Snowflake Guild -> (Guild -> Guild) -> Sem r ()+updateGuild id f = getGuild id >>= flip whenJust (setGuild . f)++updateDM :: P.Member CacheEff r => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r ()+updateDM id f = getDM id >>= flip whenJust (setDM . f)++updateUser :: P.Member CacheEff r => Snowflake User -> (User -> User) -> Sem r ()+updateUser id f = getUser id >>= flip whenJust (setUser . f)++updateMessage :: P.Member CacheEff r => Snowflake Message -> (Message -> Message) -> Sem r ()+updateMessage id f = getMessage id >>= flip whenJust (setMessage . f)

@@ -0,0 +1,123 @@+-- | A 'Cache' handler that operates in memory+module Calamity.Cache.InMemory (+  runCacheInMemory,+  runCacheInMemory',+  runCacheInMemoryNoMsg,+) where++import Calamity.Cache.Eff+import qualified Calamity.Internal.BoundedStore as BS+import qualified Calamity.Internal.SnowflakeMap as SM+import Calamity.Internal.Utils+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.User+import Calamity.Types.Snowflake++import Control.Lens+import Control.Monad.State.Strict++import Data.Foldable+import qualified Data.HashMap.Strict as SH+import qualified Data.HashSet as HS+import Data.IORef++import Control.DeepSeq+import GHC.Generics++import qualified Polysemy as P+import qualified Polysemy.AtomicState as P++data Cache f = Cache+  { user :: Maybe User+  , guilds :: SM.SnowflakeMap Guild+  , dms :: SM.SnowflakeMap DMChannel+  , guildChannels :: SH.HashMap (Snowflake GuildChannel) Guild+  , users :: SM.SnowflakeMap User+  , unavailableGuilds :: HS.HashSet (Snowflake Guild)+  , messages :: f (BS.BoundedStore Message)+  }+  deriving (Generic)++instance NFData (f (BS.BoundedStore Message)) => NFData (Cache f)++type CacheWithMsg = Cache Identity+type CacheNoMsg = Cache (Const ())++emptyCache :: CacheWithMsg+emptyCache = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty 1000)++emptyCacheNoMsg :: CacheNoMsg+emptyCacheNoMsg = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Const ())++emptyCache' :: Int -> CacheWithMsg+emptyCache' msgLimit = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty msgLimit)++-- | Run the cache in memory with a default message cache size of 1000+runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemory m = do+  var <- P.embed $ newIORef emptyCache+  P.runAtomicStateIORef var $ P.reinterpret runCache' m++-- | Run the cache in memory with no messages being cached+runCacheInMemoryNoMsg :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemoryNoMsg m = do+  var <- P.embed $ newIORef emptyCacheNoMsg+  P.runAtomicStateIORef var $ P.reinterpret runCache' m++-- | Run the cache in memory with a configurable message cache limit+runCacheInMemory' :: P.Member (P.Embed IO) r => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemory' msgLimit m = do+  var <- P.embed $ newIORef (emptyCache' msgLimit)+  P.runAtomicStateIORef var $ P.reinterpret runCache' m++runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a+runCache' act = P.atomicState' ((swap .) . force . runState $ runCache act)++class MessageMod t where+  setMessage' :: Message -> State t ()+  getMessage' :: Snowflake Message -> State t (Maybe Message)+  getMessages' :: State t [Message]+  delMessage' :: Snowflake Message -> State t ()++instance MessageMod CacheWithMsg where+  setMessage' m = #messages . _Wrapped %= BS.addItem m+  getMessage' mid = use (#messages . _Wrapped . at mid)+  getMessages' = toList <$> use (#messages . _Wrapped)+  delMessage' mid = #messages . _Wrapped %= sans mid++instance MessageMod CacheNoMsg where+  setMessage' !_ = pure ()+  getMessage' !_ = pure Nothing+  getMessages' = pure []+  delMessage' !_ = pure ()++runCache :: MessageMod (Cache t) => CacheEff m a -> State (Cache t) a+runCache (SetBotUser u) = #user ?= u+runCache GetBotUser = use #user+runCache (SetGuild g) = do+  #guilds %= SM.insert g+  #guildChannels %= SH.filter (\v -> getID @Guild v /= getID @Guild g)+  #guildChannels %= SH.union (SH.fromList $ map (,g) (SM.keys (g ^. #channels)))+runCache (GetGuild gid) = use (#guilds . at gid)+runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid))+runCache GetGuilds = SM.elems <$> use #guilds+runCache (DelGuild gid) = do+  #guilds %= sans gid+  #guildChannels %= SH.filter (\v -> getID @Guild v /= gid)+runCache (SetDM dm) = #dms %= SM.insert dm+runCache (GetDM did) = use (#dms . at did)+runCache GetDMs = SM.elems <$> use #dms+runCache (DelDM did) = #dms %= sans did+runCache (SetUser u) = #users %= SM.insert u+runCache (GetUser uid) = use (#users . at uid)+runCache GetUsers = SM.elems <$> use #users+runCache (DelUser uid) = #users %= sans uid+runCache (SetUnavailableGuild gid) = #unavailableGuilds %= HS.insert gid+runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid)+runCache GetUnavailableGuilds = HS.toList <$> use #unavailableGuilds+runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid+runCache (SetMessage m) = setMessage' m+runCache (GetMessage mid) = getMessage' mid+runCache GetMessages = getMessages'+runCache (DelMessage mid) = delMessage' mid

@@ -0,0 +1,44 @@+-- | Module containing the core client stuff+module Calamity.Client+    ( module Calamity.Client.Client+    , module Calamity.Client.Types+    -- * Client stuff+    -- $clientDocs+    ) where++import           Calamity.Client.Client+import           Calamity.Client.Types++-- $clientDocs+--+-- This module provides the core components for running a discord client, along+-- with abstractions for registering event handlers, firing custom events, and+-- waiting on events.+--+--+-- ==== Registered Metrics+--+--     1. Counter: @"events_recieved" [type, shard]@+--+--         Incremented for each event received, the @type@ parameter is the type+--         of event (the name of the constructor in+--         'Calamity.Gateway.DispatchEvents.DispatchData'), and @shard@ is the+--         ID of the shard that received the event.+--+--     2. Histogram: @"cache_update"@+--+--         Tracks how long it takes to update the cache after recieving an event.+--+--     3. Histogram: @"event_handle"@+--+--         Tracks how long it takes to process an event handler for an event.+--+--+-- ==== Examples+--+-- A simple client that prints every message recieved:+--+-- @+-- 'Control.Monad.void' . 'Polysemy.runFinal' . 'Polysemy.embedToFinal' . 'Calamity.Cache.InMemory.runCacheInMemory' . 'Calamity.Metrics.Noop.runMetricsNoop' $ 'runBotIO' ('Calamity.Types.Token.BotToken' token) $ do+--   'react' \@\''MessageCreateEvt' $ \\msg -> 'Polysemy.embed' $ 'print' msg+-- @

@@ -0,0 +1,732 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-- | The client+module Calamity.Client.Client+    ( react+    , runBotIO+    , runBotIO'+    , stopBot+    , sendPresence+    , events+    , fire+    , waitUntil+    , waitUntilM+    , CalamityEvent(Dispatch, ShutDown)+    , customEvt ) where++import           Calamity.Cache.Eff+import           Calamity.Client.ShardManager+import           Calamity.Client.Types+import           Calamity.Gateway.DispatchEvents+import           Calamity.Gateway.Types+import           Calamity.Gateway.Intents+import           Calamity.HTTP.Internal.Ratelimit+import           Calamity.Internal.ConstructorName+import           Calamity.Internal.RunIntoIO+import qualified Calamity.Internal.SnowflakeMap    as SM+import           Calamity.Internal.Updateable+import           Calamity.Internal.Utils+import           Calamity.Metrics.Eff+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.Presence     ( Presence(..) )+import           Calamity.Types.Model.User+import qualified Calamity.Types.Model.Voice as V+import           Calamity.Types.Snowflake+import           Calamity.Types.Token+import           Calamity.Types.LogEff++import           Control.Concurrent.Chan.Unagi+import           Control.Concurrent.MVar+import           Control.Concurrent.STM+import           Control.Exception                 ( SomeException )+import           Control.Lens                      hiding ( (<.>) )+import           Control.Monad++import           Data.Default.Class+import           Data.Dynamic+import           Data.Foldable+import           Data.Generics.Product.Subtype+import           Data.IORef+import           Data.Maybe+import           Data.Proxy+import qualified Data.Text                         as S+import           Data.Time.Clock.POSIX+import           Data.Typeable++import qualified Di.Core                           as DC+import qualified Df1+import qualified DiPolysemy                        as Di++import           Fmt++import qualified Polysemy                          as P+import qualified Polysemy.Async                    as P+import qualified Polysemy.AtomicState              as P+import qualified Polysemy.Error                    as P+import qualified Polysemy.Fail                     as P+import qualified Polysemy.Reader                   as P+import qualified Polysemy.Resource                 as P++import           TextShow                          ( TextShow(showt) )++timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a)+timeA m = do+  start <- P.embed getPOSIXTime+  res <- m+  end <- P.embed getPOSIXTime+  let duration = fromRational . toRational $ end - start+  pure (duration, res)+++newClient :: Token -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client+newClient token initialDi = do+  shards'        <- newTVarIO []+  numShards'     <- newEmptyMVar+  rlState'       <- newRateLimitState+  (inc, outc)    <- newChan+  ehidCounter    <- newIORef 0++  pure $ Client shards'+                numShards'+                token+                rlState'+                inc+                outc+                ehidCounter+                initialDi++-- | Create a bot, run your setup action, and then loop until the bot closes.+runBotIO :: forall r a.+         (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r))+         => Token+         -> Intents+         -- ^ The intents the bot should use+         -> P.Sem (SetupEff r) a+         -> P.Sem r (Maybe StartupError)+runBotIO token intents = runBotIO' token intents Nothing++resetDi :: BotC r => P.Sem r a -> P.Sem r a+resetDi m = do+  initialDi <- P.asks (^. #initialDi)+  Di.local (flip fromMaybe initialDi) m++-- | Create a bot, run your setup action, and then loop until the bot closes.+--+-- This version allows you to specify the initial status, and intents.+runBotIO' :: forall r a.+          (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r))+          => Token+          -> Intents+          -- ^ The intents the bot should use+          -> Maybe StatusUpdateData+          -- ^ The initial status to send to the gateway+          -> P.Sem (SetupEff r) a+          -> P.Sem r (Maybe StartupError)+runBotIO' token intents status setup = do+  initialDi <- Di.fetch+  client <- P.embed $ newClient token initialDi+  handlers <- P.embed $ newTVarIO def+  P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do+    void $ Di.push "calamity-setup" setup+    r <- shardBot status intents+    case r of+      Left e  -> pure (Just e)+      Right _ -> do+        Di.push "calamity-loop" clientLoop+        Di.push "calamity-stop" finishUp+        pure Nothing++-- | Register an event handler, returning an action that removes the event handler from the bot.+--+-- Refer to 'EventType' for what events you can register, and 'EHType' for the+-- parameters the event handlers they receive.+--+-- You'll probably want @TypeApplications@ and need @DataKinds@ enabled to+-- specify the type of @s@.+--+-- ==== Examples+--+-- Reacting to every message:+--+-- @+-- 'react' @\''MessageCreateEvt' '$' \msg -> 'print' '$' "Got message: " '<>' 'show' msg+-- @+--+-- Reacting to a custom event:+--+-- @+-- 'react' @(\''CustomEvt' "my-event" ('Data.Text.Text', 'Message')) $ \\(s, m) ->+--    'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s)+-- @+--+-- ==== Notes+--+-- This function is pretty bad for giving nasty type errors,+-- since if something doesn't match then 'EHType' might not get substituted,+-- which will result in errors about parameter counts mismatching.+react :: forall (s :: EventType) r.+      (BotC r, ReactConstraints s)+      => (EHType s -> (P.Sem r) ())+      -> P.Sem r (P.Sem r ())+react handler = do+  handler' <- bindSemToIO handler+  ehidC <- P.asks (^. #ehidCounter)+  id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i))+  let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler')+  P.atomicModify (handlers <>)+  pure $ removeHandler @s id'++removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r ()+removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id')++-- | Fire an event that the bot will then handle.+--+-- ==== Examples+--+-- Firing an event named \"my-event\":+--+-- @+-- 'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg)+-- @+fire :: BotC r => CalamityEvent -> P.Sem r ()+fire e = do+  inc <- P.asks (^. #eventsIn)+  P.embed $ writeChan inc e++-- | Build a Custom CalamityEvent+--+-- You'll probably want @TypeApplications@ to specify the type of @s@.+--+-- The types of @s@ and @a@ must match up with the event handler you want to+-- receive it.+--+-- ==== Examples+--+-- Building an event named \"my-event\":+--+-- @+-- 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg)+-- @+customEvt :: forall s a. (Typeable s, Typeable a) => a -> CalamityEvent+customEvt x = Custom (typeRep $ Proxy @s) (toDyn x)++-- | Get a copy of the event stream.+events :: BotC r => P.Sem r (OutChan CalamityEvent)+events = do+  inc <- P.asks (^. #eventsIn)+  P.embed $ dupChan inc++-- | Wait until an event satisfying a condition happens, then returns it's+-- parameters.+--+-- The check function for this command is pure unlike 'waitUntilM'+--+-- This is what it would look like with @s ~ \''MessageCreateEvt'@:+--+-- @+-- 'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message'+-- @+--+-- And for @s ~ \''MessageUpdateEvt'@:+--+-- @+-- 'waitUntil' :: (('Message', 'Message') -> 'Bool') -> 'P.Sem' r ('Message', 'Message')+-- @+--+-- ==== Examples+--+-- Waiting for a message containing the text \"hi\":+--+-- @+-- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)+--        print $ msg ^. #content+-- @+waitUntil+  :: forall (s :: EventType) r.+  ( BotC r, ReactConstraints s)+  => (EHType s -> Bool)+  -> P.Sem r (EHType s)+waitUntil f = P.resourceToIOFinal $ do+  result <- P.embed newEmptyMVar+  P.bracket (P.raise $ react @s (checker result))+            P.raise+            (const . P.embed $ takeMVar result)+  where+    checker :: MVar (EHType s) -> EHType s -> P.Sem r ()+    checker result args = do+      when (f args) $ do+        P.embed $ putMVar result args++-- | Wait until an event satisfying a condition happens, then returns it's+-- parameters+--+-- This is what it would look like with @s ~ \''MessageCreateEvt'@:+--+-- @+-- 'waitUntilM' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message'+-- @+--+-- And for @s ~ \''MessageUpdateEvt'@:+--+-- @+-- 'waitUntilM' :: (('Message', 'Message') -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message')+-- @+--+-- ==== Examples+--+-- Waiting for a message containing the text \"hi\":+--+-- @+-- f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content))+--        print $ msg ^. #content+-- @+waitUntilM+  :: forall (s :: EventType) r.+  ( BotC r, ReactConstraints s)+  => (EHType s -> P.Sem r Bool)+  -> P.Sem r (EHType s)+waitUntilM f = P.resourceToIOFinal $ do+  result <- P.embed newEmptyMVar+  P.bracket (P.raise $ react @s (checker result))+            P.raise+            (const . P.embed $ takeMVar result)+  where+    checker :: MVar (EHType s) -> EHType s -> P.Sem r ()+    checker result args = do+      res <- f args+      when res $ do+        P.embed $ putMVar result args++-- | Set the bot's presence on all shards.+sendPresence :: BotC r => StatusUpdateData -> P.Sem r ()+sendPresence s = do+  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+  for_ shards $ \(inc, _) ->+    P.embed $ writeChan inc (SendPresence s)++-- | Initiate shutting down the bot.+stopBot :: BotC r => P.Sem r ()+stopBot = do+  debug "stopping bot"+  inc <- P.asks (^. #eventsIn)+  P.embed $ writeChan inc ShutDown++finishUp :: BotC r => P.Sem r ()+finishUp = do+  debug "finishing up"+  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+  for_ shards $ \(inc, _) ->+    P.embed $ writeChan inc ShutDownShard+  for_ shards $ \(_, shardThread) -> P.await shardThread+  debug "bot has stopped"++-- | main loop of the client, handles fetching the next event, processing the+-- event and invoking it's handler functions+clientLoop :: BotC r => P.Sem r ()+clientLoop = do+  outc <- P.asks (^. #eventsOut)+  whileMFinalIO $ do+    !evt' <- P.embed $ readChan outc+    case evt' of+      Dispatch !sid !evt -> handleEvent sid evt >> pure True+      Custom !s !d       -> handleCustomEvent s d >> pure True+      ShutDown           -> pure False+  debug "leaving client loop"++handleCustomEvent :: forall r. BotC r => TypeRep -> Dynamic -> P.Sem r ()+handleCustomEvent s d = do+  debug $ "handling a custom event, s: " +|| s ||+ ", d: " +|| d ||+ ""+  eventHandlers <- P.atomicGet++  let handlers = getCustomEventHandlers s (dynTypeRep d) eventHandlers++  for_ handlers (\h -> P.async . P.embed $ h d)++catchAllLogging :: BotC r => P.Sem r () -> P.Sem r ()+catchAllLogging m = do+  r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m+  case r of+    Right _ -> pure ()+    Left e -> debug $ "got exception: " +|| e ||+ ""++handleEvent :: BotC r => Int -> DispatchData -> P.Sem r ()+handleEvent shardID data' = do+  debug "handling an event"+  eventHandlers <- P.atomicGet+  actions <- P.runFail $ do+    evtCounter <- registerCounter "events_received" [("type", S.pack $ ctorName data'), ("shard", showt shardID)]+    void $ addCounter 1 evtCounter+    cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20..100]+    (time, res) <- timeA $ resetDi $ handleEvent' eventHandlers data'+    void $ observeHistogram time cacheUpdateHisto+    pure res++  eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20..100]++  case actions of+    Right actions -> for_ actions $ \action -> P.async $ do+      (time, _) <- timeA . catchAllLogging $ P.embed action+      void $ observeHistogram time eventHandleHisto+    -- pattern match failures are usually stuff like events for uncached guilds, etc+    Left err      -> debug $ "Failed handling actions for event: " +| err |+ ""++handleEvent' :: BotC r+              => EventHandlers+              -> DispatchData+              -> P.Sem (P.Fail ': r) [IO ()]+handleEvent' eh evt@(Ready rd@ReadyData {}) = do+  updateCache evt+  pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh)++handleEvent' _ Resumed = pure []++handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do+  updateCache evt+  Just newChan <- DMChannel' <<$>> getDM (getID chan)+  pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh)++handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do+  updateCache evt+  Just guild <- getGuild (getID chan)+  Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan)+  pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh)++handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do+  Just oldChan <- DMChannel' <<$>> getDM (getID chan)+  updateCache evt+  Just newChan <- DMChannel' <<$>> getDM (getID chan)+  pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh)++handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do+  Just oldGuild <- getGuild (getID chan)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+  updateCache evt+  Just newGuild <- getGuild (getID chan)+  Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan)+  pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh)++handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do+  Just oldGuild <- getGuild (getID chan)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+  updateCache evt+  pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)++handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do+  Just oldChan <- DMChannel' <<$>> getDM (getID chan)+  updateCache evt+  pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh)++-- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do+--   chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just)+--     <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just)+--   pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh)++handleEvent' eh evt@(GuildCreate guild) = do+  isNew <- not <$> isUnavailableGuild (getID guild)+  updateCache evt+  Just guild <- getGuild (getID guild)+  pure $ map ($ (guild, (if isNew then GuildCreateNew else GuildCreateAvailable)))+    (getEventHandlers @'GuildCreateEvt eh)++handleEvent' eh evt@(GuildUpdate guild) = do+  Just oldGuild <- getGuild (getID guild)+  updateCache evt+  Just newGuild <- getGuild (getID guild)+  pure $ map ($ (oldGuild, newGuild)) (getEventHandlers @'GuildUpdateEvt eh)++-- NOTE: Guild will be deleted in the new cache if unavailable was false+handleEvent' eh evt@(GuildDelete UnavailableGuild { id, unavailable }) = do+  Just oldGuild <- getGuild id+  updateCache evt+  pure $ map ($ (oldGuild, (if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved)))+    (getEventHandlers @'GuildDeleteEvt eh)++handleEvent' eh evt@(GuildBanAdd BanData { guildID, user }) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanAddEvt eh)++handleEvent' eh evt@(GuildBanRemove BanData { guildID, user }) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanRemoveEvt eh)++-- NOTE: we fire this event using the guild data with old emojis+handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map ($ (guild, emojis)) (getEventHandlers @'GuildEmojisUpdateEvt eh)++handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData { guildID }) = do+  updateCache evt+  Just guild <- getGuild guildID+  pure $ map ($ guild) (getEventHandlers @'GuildIntegrationsUpdateEvt eh)++handleEvent' eh evt@(GuildMemberAdd member) = do+  updateCache evt+  Just guild <- getGuild (getID member)+  Just member <- pure $ guild ^. #members . at (getID member)+  pure $ map ($ member) (getEventHandlers @'GuildMemberAddEvt eh)++handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData { user, guildID }) = do+  Just guild <- getGuild guildID+  Just member <- pure $ guild ^. #members . at (getID user)+  updateCache evt+  pure $ map ($ member) (getEventHandlers @'GuildMemberRemoveEvt eh)++handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData { user, guildID }) = do+  Just oldGuild <- getGuild guildID+  Just oldMember <- pure $ oldGuild ^. #members . at (getID user)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newMember <- pure $ newGuild ^. #members . at (getID user)+  pure $ map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)++handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData { members, guildID }) = do+  updateCache evt+  Just guild <- getGuild guildID+  let members' = guild ^.. #members . foldMap (at . getID) members . _Just+  pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh)++handleEvent' eh evt@(GuildRoleCreate GuildRoleData { guildID, role }) = do+  updateCache evt+  Just guild <- getGuild guildID+  Just role' <- pure $ guild ^. #roles . at (getID role)+  pure $ map ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh)++handleEvent' eh evt@(GuildRoleUpdate GuildRoleData { guildID, role }) = do+  Just oldGuild <- getGuild guildID+  Just oldRole <- pure $ oldGuild ^. #roles . at (getID role)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newRole <- pure $ newGuild ^. #roles . at (getID role)+  pure $ map ($ (newGuild, oldRole, newRole)) (getEventHandlers @'GuildRoleUpdateEvt eh)++handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = do+  Just guild <- getGuild guildID+  Just role <- pure $ guild ^. #roles . at roleID+  updateCache evt+  pure $ map ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh)++handleEvent' eh (InviteCreate d) = do+  pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh)++handleEvent' eh (InviteDelete d) = do+  pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh)++handleEvent' eh evt@(MessageCreate msg _) = do+  updateCache evt+  pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh)++handleEvent' eh evt@(MessageUpdate msg) = do+  oldMsg <- getMessage (getID msg)+  updateCache evt+  newMsg <- getMessage (getID msg)+  let rawActions = map ($ msg) (getEventHandlers @'RawMessageUpdateEvt eh)+  let actions = case (oldMsg, newMsg) of+                  (Just oldMsg', Just newMsg') ->+                    map ($ (oldMsg', newMsg')) (getEventHandlers @'MessageUpdateEvt eh)+                  _ -> []+  pure $ rawActions <> actions++handleEvent' eh evt@(MessageDelete MessageDeleteData { id }) = do+  oldMsg <- getMessage id+  updateCache evt+  let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh)+  let actions = case oldMsg of+        Just oldMsg' ->+          map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh)+        _ -> []+  pure $ rawActions <> actions++handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData { ids }) = do+  messages <- catMaybes <$> traverse getMessage ids+  updateCache evt+  let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh)+  let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh)+  pure $ rawActions <> actions++handleEvent' eh evt@(MessageReactionAdd reaction) = do+  updateCache evt+  msg <- getMessage (getID reaction)+  let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh)+  let actions = case msg of+        Just msg' ->+          map ($ (msg', reaction)) (getEventHandlers @'MessageReactionAddEvt eh)+        _ -> []+  pure $ rawActions <> actions++handleEvent' eh evt@(MessageReactionRemove reaction) = do+  msg <- getMessage (getID reaction)+  updateCache evt+  let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh)+  let actions = case msg of+        Just msg' ->+          map ($ (msg', reaction)) (getEventHandlers @'MessageReactionRemoveEvt eh)+        _ -> []+  pure $ rawActions <> actions++handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = do+  msg <- getMessage messageID+  updateCache evt+  let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh)+  let actions = case msg of+        Just msg' ->+          map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh)+        _ -> []+  pure $ rawActions <> actions++handleEvent' eh evt@(PresenceUpdate PresenceUpdateData { userID, presence = Presence { guildID } }) = do+  Just oldGuild <- getGuild guildID+  Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID)+  let oldUser :: User = upcast oldMember+      newUser :: User = upcast newMember+      userUpdates = if oldUser /= newUser+                    then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)+                    else mempty+  pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh)++handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp }) =+  case guildID of+    Just gid -> do+      Just guild <- getGuild gid+      Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)+      pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)+    Nothing -> do+      Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID)+      pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh)++handleEvent' eh evt@(UserUpdate _) = do+  Just oldUser <- getBotUser+  updateCache evt+  Just newUser <- getBotUser+  pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh)++handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState{guildID=Just guildID}) = do+  oldVoiceState <- join . fmap (find ((==V.sessionID newVoiceState) . V.sessionID) . voiceStates) <$> getGuild guildID+  updateCache evt+  pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @'VoiceStateUpdateEvt eh)++handleEvent' _ e = fail $ "Unhandled event: " <> show e++updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r ()+updateCache (Ready ReadyData { user, guilds }) = do+  setBotUser user+  for_ (map getID guilds) setUnavailableGuild++updateCache Resumed = pure ()++updateCache (ChannelCreate (DMChannel' chan)) =+  setDM chan++updateCache (ChannelCreate (GuildChannel' chan)) =+  updateGuild (getID chan) (#channels %~ SM.insert chan)++updateCache (ChannelUpdate (DMChannel' chan)) =+  updateDM (getID chan) (update chan)++updateCache (ChannelUpdate (GuildChannel' chan)) =+  updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan)++updateCache (ChannelDelete (DMChannel' chan)) =+  delDM (getID chan)++updateCache (ChannelDelete (GuildChannel' chan)) =+  updateGuild (getID chan) (#channels %~ sans (getID chan))++updateCache (GuildCreate guild) = do+  isNew <- isUnavailableGuild (getID guild)+  when isNew $ delUnavailableGuild (getID guild)+  setGuild guild+  for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser++updateCache (GuildUpdate guild) =+  updateGuild (getID guild) (update guild)++updateCache (GuildDelete UnavailableGuild { id, unavailable }) =+  if unavailable+  then setUnavailableGuild id+  else delGuild id++updateCache (GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) =+  updateGuild guildID (#emojis .~ SM.fromList emojis)++updateCache (GuildMemberAdd member) = do+  setUser (member ^. super)+  updateGuild (getID member) (#members . at (getID member) ?~ member)++updateCache (GuildMemberRemove GuildMemberRemoveData { guildID, user }) =+  updateGuild guildID (#members %~ sans (getID user))++updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles, user, nick }) = do+  setUser user+  updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick))++updateCache (GuildMembersChunk GuildMembersChunkData { members }) =+  traverse_ (updateCache . GuildMemberAdd) members++updateCache (GuildRoleCreate GuildRoleData { guildID, role }) =+  updateGuild guildID (#roles %~ SM.insert role)++updateCache (GuildRoleUpdate GuildRoleData { guildID, role }) =+  updateGuild guildID (#roles %~ SM.insert role)++updateCache (GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) =+  updateGuild guildID (#roles %~ sans roleID)++updateCache (MessageCreate !msg !user) = do+  setMessage msg+  for_ user setUser++updateCache (MessageUpdate msg) =+  updateMessage (getID msg) (update msg)++updateCache (MessageDelete MessageDeleteData { id }) = delMessage id++updateCache (MessageDeleteBulk MessageDeleteBulkData { ids }) =+  for_ ids delMessage++updateCache (MessageReactionAdd reaction) =+  updateMessage (getID reaction) (#reactions %~ cons reaction)++updateCache (MessageReactionRemove reaction) =+  updateMessage (getID reaction) (#reactions %~ filter (\r -> r ^. #emoji /= reaction ^. #emoji))++updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) =+  updateMessage messageID (#reactions .~ mempty)++updateCache (PresenceUpdate PresenceUpdateData { userID, presence }) =+  updateGuild (getID presence) (#presences . at userID ?~ presence)++updateCache (UserUpdate user) = setBotUser user++-- we don't handle group channels currently+updateCache (ChannelCreate (GroupChannel' _)) = pure ()+updateCache (ChannelUpdate (GroupChannel' _)) = pure ()+updateCache (ChannelDelete (GroupChannel' _)) = pure ()++-- these don't modify state+updateCache (GuildBanAdd _) = pure ()+updateCache (GuildBanRemove _) = pure ()+updateCache (GuildIntegrationsUpdate _) = pure ()+updateCache (TypingStart _) = pure ()+updateCache (ChannelPinsUpdate _) = pure ()+updateCache (WebhooksUpdate _) = pure ()+updateCache (InviteCreate _) = pure ()+updateCache (InviteDelete _) = pure ()++updateCache (VoiceStateUpdate voiceState@V.VoiceState{guildID=Just guildID}) =+  updateGuild guildID (#voiceStates %~ updateVoiceStates)+  where+    updateVoiceStates [] = [voiceState]+    updateVoiceStates (x:xs)+        | V.sessionID x == V.sessionID voiceState = voiceState : xs+        | otherwise = x : updateVoiceStates xs++  -- we don't handle voice server update and direct voice connections currently+updateCache (VoiceStateUpdate V.VoiceState{guildID=Nothing}) = pure ()+updateCache (VoiceServerUpdate _) = pure ()

@@ -0,0 +1,52 @@+-- | Contains stuff for managing shards+module Calamity.Client.ShardManager+    ( shardBot ) where++import           Calamity.Client.Types+import           Calamity.Gateway+import           Calamity.HTTP+import           Calamity.Internal.Utils++import           Control.Concurrent.MVar+import           Control.Concurrent.STM+import           Control.Lens+import           Control.Monad++import           Data.Traversable++import           Fmt++import           Polysemy                    ( Sem )+import qualified Polysemy.Fail               as P+import qualified Polysemy                    as P+import qualified Polysemy.Reader             as P++mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f (Left a) = Left $ f a+mapLeft _ (Right b) = Right b++-- | Connects the bot to the gateway over n shards+shardBot :: BotC r => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ())+shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do+  numShardsVar <- P.asks numShards+  shardsVar <- P.asks shards++  hasShards <- P.embed $ not . null <$> readTVarIO shardsVar+  when hasShards $ fail "don't use shardBot on an already running bot."++  token <- P.asks Calamity.Client.Types.token+  inc <- P.asks (^. #eventsIn)++  Right gateway <- invoke GetGatewayBot++  let numShards' = gateway ^. #shards+  let host = gateway ^. #url+  P.embed $ putMVar numShardsVar numShards'++  info $ "Number of shards: " +| numShards' |+ ""++  shards <- for [0 .. numShards' - 1] $ \id ->+    newShard host id numShards' token initialStatus intents inc++  P.embed . atomically $ writeTVar shardsVar shards+

@@ -0,0 +1,354 @@+-- | Types for the client+module Calamity.Client.Types+    ( Client(..)+    , StartupError(..)+    , EventType(..)+    , GuildCreateStatus(..)+    , GuildDeleteStatus(..)+    , EHType+    , BotC+    , SetupEff+    , ReactConstraints+    , EventHandlers(..)+    , InsertEventHandler(..)+    , RemoveEventHandler(..)+    , getEventHandlers+    , getCustomEventHandlers ) where++import           Calamity.Cache.Eff+import           Calamity.Gateway.DispatchEvents ( CalamityEvent(..), InviteCreateData, InviteDeleteData, ReadyData )+import           Calamity.Gateway.Types          ( ControlMessage )+import           Calamity.HTTP.Internal.Types+import           Calamity.Metrics.Eff+import           Calamity.Types.LogEff+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Channel.UpdatedMessage+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Model.Voice+import           Calamity.Types.Token+import           Calamity.Types.UnixTimestamp+import           Calamity.Types.Snowflake++import           Control.Concurrent.Async+import           Control.Concurrent.Chan.Unagi+import           Control.Concurrent.MVar+import           Control.Concurrent.STM.TVar++import           Data.Default.Class+import           Data.Dynamic+import qualified Data.HashMap.Lazy               as LH+import           Data.IORef+import           Data.Maybe+import           Data.Time+import qualified Data.TypeRepMap                 as TM+import           Data.TypeRepMap                 ( TypeRepMap, WrapTypeable(..) )+import           Data.Typeable+import           Data.Void++import           GHC.Exts                        ( fromList )+import           GHC.Generics++import qualified Polysemy                        as P+import qualified Polysemy.Async                  as P+import qualified Polysemy.AtomicState            as P+import qualified Polysemy.Reader                 as P++import qualified TextShow.Generic                as TSG+import TextShow+import qualified Df1 as Df1+import qualified Di.Core as DC++data Client = Client+  { shards              :: TVar [(InChan ControlMessage, Async (Maybe ()))]+  , numShards           :: MVar Int+  , token               :: Token+  , rlState             :: RateLimitState+  , eventsIn            :: InChan CalamityEvent+  , eventsOut           :: OutChan CalamityEvent+  , ehidCounter         :: IORef Integer+  , initialDi           :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message)+  }+  deriving ( Generic )++type BotC r =+  ( P.Members '[LogEff, MetricEff, CacheEff, P.Reader Client,+  P.AtomicState EventHandlers, P.Embed IO, P.Final IO, P.Async] r+  , Typeable r)++-- | A concrete effect stack used inside the bot+type SetupEff r = (P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r)++-- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't+-- worry about these since they are satisfied for any type @s@ can be+type ReactConstraints s =+  ( InsertEventHandler s+  , RemoveEventHandler s+  )++newtype StartupError = StartupError String+  deriving ( Show )++-- | A Data Kind used to fire custom events+data EventType+  = ReadyEvt+  | ChannelCreateEvt+  | ChannelUpdateEvt+  | ChannelDeleteEvt+  | ChannelpinsUpdateEvt+  | GuildCreateEvt+  | GuildUpdateEvt+  | GuildDeleteEvt+  | GuildBanAddEvt+  | GuildBanRemoveEvt+  | GuildEmojisUpdateEvt+  | GuildIntegrationsUpdateEvt+  | GuildMemberAddEvt+  | GuildMemberRemoveEvt+  | GuildMemberUpdateEvt+  | GuildMembersChunkEvt+  | GuildRoleCreateEvt+  | GuildRoleUpdateEvt+  | GuildRoleDeleteEvt+  | InviteCreateEvt+  | InviteDeleteEvt+  | MessageCreateEvt+  | MessageUpdateEvt+  -- ^ Fired when a cached message is updated, use 'RawMessageUpdateEvt' to see+  -- updates of uncached messages+  | RawMessageUpdateEvt+  -- ^ Fired when a message is updated+  | MessageDeleteEvt+  -- ^ Fired when a cached message is deleted, use 'RawMessageDeleteEvt' to see+  -- deletes of uncached messages.+  --+  -- Does not include messages deleted through bulk deletes, use+  -- 'MessageDeleteBulkEvt' for those+  | RawMessageDeleteEvt+  -- ^ Fired when a message is deleted.+  --+  -- Does not include messages deleted through bulk deletes, use+  -- 'RawMessageDeleteBulkEvt' for those+  | MessageDeleteBulkEvt+  -- ^ Fired when messages are bulk deleted. Only includes cached messages, use+  -- 'RawMessageDeleteBulkEvt' to see deletes of uncached messages.+  | RawMessageDeleteBulkEvt+  -- ^ Fired when messages are bulk deleted.+  | MessageReactionAddEvt+  -- ^ Fired when a reaction is added to a cached message, use+  -- 'RawMessageReactionAddEvt' to see reactions on uncached messages.+  | RawMessageReactionAddEvt+  -- ^ Fired when a reaction is added to a message.+  | MessageReactionRemoveEvt+  -- ^ Fired when a reaction is removed from a cached message, use+  -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages.+  | RawMessageReactionRemoveEvt+  -- ^ Fired when a reaction is removed from a message.+  | MessageReactionRemoveAllEvt+  -- ^ Fired when all reactions are removed from a cached message, use+  -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages.+  --+  -- The message passed will contain the removed events.+  | RawMessageReactionRemoveAllEvt+  -- ^ Fired when all reactions are removed from a message.+  | TypingStartEvt+  | UserUpdateEvt+  | VoiceStateUpdateEvt+  -- ^ Sent when someone joins/leaves/moves voice channels+  | forall s a. CustomEvt s a+  -- ^ A custom event, @s@ is the name and @a@ is the data sent to the handler++data GuildCreateStatus+  = GuildCreateNew -- ^ The guild was just joined+  | GuildCreateAvailable -- ^ The guild is becoming available+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric GuildCreateStatus++data GuildDeleteStatus+  = GuildDeleteUnavailable -- ^ The guild became unavailable+  | GuildDeleteRemoved -- ^ The bot was removed from the guild+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric GuildDeleteStatus++-- | A type family to decide what the parameters for an event handler should be+-- determined by the type of event it is handling.+type family EHType (d :: EventType) where+  EHType 'ReadyEvt                    = ReadyData+  EHType 'ChannelCreateEvt            = Channel+  EHType 'ChannelUpdateEvt            = (Channel, Channel)+  EHType 'ChannelDeleteEvt            = Channel+  EHType 'ChannelpinsUpdateEvt        = (Channel, Maybe UTCTime)+  EHType 'GuildCreateEvt              = (Guild, GuildCreateStatus)+  EHType 'GuildUpdateEvt              = (Guild, Guild)+  EHType 'GuildDeleteEvt              = (Guild, GuildDeleteStatus)+  EHType 'GuildBanAddEvt              = (Guild, User)+  EHType 'GuildBanRemoveEvt           = (Guild, User)+  EHType 'GuildEmojisUpdateEvt        = (Guild, [Emoji])+  EHType 'GuildIntegrationsUpdateEvt  = Guild+  EHType 'GuildMemberAddEvt           = Member+  EHType 'GuildMemberRemoveEvt        = Member+  EHType 'GuildMemberUpdateEvt        = (Member, Member)+  EHType 'GuildMembersChunkEvt        = (Guild, [Member])+  EHType 'GuildRoleCreateEvt          = (Guild, Role)+  EHType 'GuildRoleUpdateEvt          = (Guild, Role, Role)+  EHType 'GuildRoleDeleteEvt          = (Guild, Role)+  EHType 'InviteCreateEvt             = InviteCreateData+  EHType 'InviteDeleteEvt             = InviteDeleteData+  EHType 'MessageCreateEvt            = Message+  EHType 'MessageUpdateEvt            = (Message, Message)+  EHType 'MessageDeleteEvt            = Message+  EHType 'MessageDeleteBulkEvt        = [Message]+  EHType 'MessageReactionAddEvt       = (Message, Reaction)+  EHType 'MessageReactionRemoveEvt    = (Message, Reaction)+  EHType 'MessageReactionRemoveAllEvt = Message+  EHType 'RawMessageUpdateEvt            = UpdatedMessage+  EHType 'RawMessageDeleteEvt            = Snowflake Message+  EHType 'RawMessageDeleteBulkEvt        = [Snowflake Message]+  EHType 'RawMessageReactionAddEvt       = Reaction+  EHType 'RawMessageReactionRemoveEvt    = Reaction+  EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message+  EHType 'TypingStartEvt              = (Channel, Snowflake User, UnixTimestamp)+  EHType 'UserUpdateEvt               = (User, User)+  EHType 'VoiceStateUpdateEvt         = (Maybe VoiceState, VoiceState)+  EHType ('CustomEvt s a)             = a++type StoredEHType t = EHType t -> IO ()++newtype EventHandlers = EventHandlers (TypeRepMap EventHandler)++data EventHandlerWithID a = EventHandlerWithID+  { ehID :: Integer+  , eh   :: a+  }++type family EHStorageType (t :: EventType) where+  EHStorageType ('CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [EventHandlerWithID (StoredEHType ('CustomEvt s a))])+  EHStorageType t                = [EventHandlerWithID (StoredEHType t)]++newtype EventHandler (t :: EventType) = EH+  { unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t+  }++instance Semigroup (EventHandler t) where+  EH a <> EH b = EH $ a <> b++instance Monoid (EventHandler t) where+  mempty = EH mempty++instance Default EventHandlers where+  def = EventHandlers $ fromList [ WrapTypeable $ EH @'ReadyEvt []+                                 , WrapTypeable $ EH @'ChannelCreateEvt []+                                 , WrapTypeable $ EH @'ChannelUpdateEvt []+                                 , WrapTypeable $ EH @'ChannelDeleteEvt []+                                 , WrapTypeable $ EH @'ChannelpinsUpdateEvt []+                                 , WrapTypeable $ EH @'GuildCreateEvt []+                                 , WrapTypeable $ EH @'GuildUpdateEvt []+                                 , WrapTypeable $ EH @'GuildDeleteEvt []+                                 , WrapTypeable $ EH @'GuildBanAddEvt []+                                 , WrapTypeable $ EH @'GuildBanRemoveEvt []+                                 , WrapTypeable $ EH @'GuildEmojisUpdateEvt []+                                 , WrapTypeable $ EH @'GuildIntegrationsUpdateEvt []+                                 , WrapTypeable $ EH @'GuildMemberAddEvt []+                                 , WrapTypeable $ EH @'GuildMemberRemoveEvt []+                                 , WrapTypeable $ EH @'GuildMemberUpdateEvt []+                                 , WrapTypeable $ EH @'GuildMembersChunkEvt []+                                 , WrapTypeable $ EH @'GuildRoleCreateEvt []+                                 , WrapTypeable $ EH @'GuildRoleUpdateEvt []+                                 , WrapTypeable $ EH @'GuildRoleDeleteEvt []+                                 , WrapTypeable $ EH @'MessageCreateEvt []+                                 , WrapTypeable $ EH @'MessageUpdateEvt []+                                 , WrapTypeable $ EH @'MessageDeleteEvt []+                                 , WrapTypeable $ EH @'MessageDeleteBulkEvt []+                                 , WrapTypeable $ EH @'MessageReactionAddEvt []+                                 , WrapTypeable $ EH @'MessageReactionRemoveEvt []+                                 , WrapTypeable $ EH @'MessageReactionRemoveAllEvt []+                                 , WrapTypeable $ EH @'TypingStartEvt []+                                 , WrapTypeable $ EH @'UserUpdateEvt []+                                 , WrapTypeable $ EH @('CustomEvt Void Dynamic) LH.empty+                                 ]++instance Semigroup EventHandlers where+  (EventHandlers a) <> (EventHandlers b) = EventHandlers $ TM.unionWith (<>) a b++instance Monoid EventHandlers where+  mempty = def++-- not sure what to think of this++type family EHInstanceSelector (d :: EventType) :: Bool where+  EHInstanceSelector ('CustomEvt _ _) = 'True+  EHInstanceSelector _                = 'False+++fromDynamicJust :: forall a. Typeable a => Dynamic -> a+fromDynamicJust d = case fromDynamic d of+  Just x -> x+  Nothing -> error $ "Extracting dynamic failed, wanted: " <> (show . typeRep $ Proxy @a) <> ", got: " <> (show $ dynTypeRep d)+++-- | A helper typeclass that is used to decide how to register regular+-- events, and custom events which require storing in a map at runtime.+class InsertEventHandler a where+  makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers++instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a) => InsertEventHandler a where+  makeEventHandlers = makeEventHandlers' (Proxy @flag)++class InsertEventHandler' (flag :: Bool) a where+  makeEventHandlers' :: Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers++intoDynFn :: forall a. Typeable a => (a -> IO ()) -> (Dynamic -> IO ())+intoDynFn fn = \d -> fn $ fromDynamicJust d++instance (Typeable a, Typeable s, Typeable (StoredEHType ('CustomEvt s a)), (EHType ('CustomEvt s a) -> IO ()) ~ (a -> IO ()))+  => InsertEventHandler' 'True ('CustomEvt s a) where+  makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @('CustomEvt Void Dynamic)+    (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [EventHandlerWithID id' (intoDynFn handler)]))++instance (Typeable s, EHStorageType s ~ [EventHandlerWithID (StoredEHType s)], Typeable (StoredEHType s)) => InsertEventHandler' 'False s where+  makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @s [EventHandlerWithID id' handler]+++class GetEventHandlers a where+  getEventHandlers :: EventHandlers -> [StoredEHType a]++instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a) => GetEventHandlers a where+  getEventHandlers = getEventHandlers' (Proxy @a) (Proxy @flag)++class GetEventHandlers' (flag :: Bool) a where+  getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a]++instance GetEventHandlers' 'True ('CustomEvt s a) where+  getEventHandlers' _ _ _ = error "use getCustomEventHandlers instead"++instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where+  getEventHandlers' _ _ (EventHandlers handlers) =+    let theseHandlers = unwrapEventHandler @s $ fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler s))+    in map eh theseHandlers+++class RemoveEventHandler a where+  removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers++instance (EHInstanceSelector a ~ flag, RemoveEventHandler' flag a) => RemoveEventHandler a where+  removeEventHandler = removeEventHandler' (Proxy @flag)++class RemoveEventHandler' (flag :: Bool) a where+  removeEventHandler' :: Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers++instance (Typeable s, Typeable a) => RemoveEventHandler' 'True ('CustomEvt s a) where+  removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @('CustomEvt Void Dynamic)+    (\(EH ehs) -> EH (LH.update (Just . LH.update (Just . filter ((/= id') . ehID)) (typeRep $ Proxy @a))+                      (typeRep $ Proxy @s) ehs)) handlers++instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)])+  => RemoveEventHandler' 'False s where+  removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @s+    (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs) handlers+++getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic -> IO ()]+getCustomEventHandlers s a (EventHandlers handlers) =+    let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromMaybe mempty+          (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic)))+    in map eh . concat $ LH.lookup s handlerMap >>= LH.lookup a

@@ -0,0 +1,78 @@+-- | Calamity commands+-- This module exports the DSL and core types for using commands+module Calamity.Commands+    ( module Calamity.Commands.Dsl+    , module Calamity.Commands.Error+    , module Calamity.Commands.Handler+    , module Calamity.Commands.Utils+    , module Calamity.Commands.ParsePrefix+    , module Calamity.Commands.Parser+    , module Calamity.Commands.Help+    , module Calamity.Commands.Context+    -- * Commands+    -- $commandDocs+    ) where++import           Calamity.Commands.Dsl+import           Calamity.Commands.Error+import           Calamity.Commands.Handler+import           Calamity.Commands.Help+import           Calamity.Commands.ParsePrefix+import           Calamity.Commands.Parser+import           Calamity.Commands.Utils+import           Calamity.Commands.Context ( Context )++-- $commandDocs+--+-- This module provides abstractions for writing declarative commands, that+-- support grouping, pre-invokation checks, and automatic argument parsing by+-- using a type level list of parameter types.+--+-- A DSL is provided in "Calamity.Commands.Dsl" for constructing commands+-- declaratively.+--+-- You can implement 'Parser' for your own types to allow them to be used in the+-- parameter list of commands.+--+-- A default help command is provided in "Calamity.Commands.Help" which can be+-- added just by using 'helpCommand' inside the command declaration DSL.+--+--+-- ==== Custom Events+--+-- The event handler registered by 'addCommands' will fire the following custom events:+--+--     1. @"command-error" ('Context', 'CommandError')@+--+--         Fired when a command returns an error.+--+--     2. @"command-not-found" ('Calamity.Types.Model.Channel.Message', ['Data.Text.Lazy.Text'])@+--+--         Fired when a valid prefix is used, but the command is not found.+--+--     3. @"command-invoked" 'Context'@+--+--         Fired when a command is successfully invoked.+--+-- ==== Registered Metrics+--+--     1. Counter: @"commands_invoked" [name]@+--+--         Incremented on each command invokation, the parameter @name@ is the+--         path/name of the invoked command.+--+--+-- ==== Examples+--+-- An example of using commands:+--+-- @+-- 'addCommands' $ do+--   'helpCommand'+--   'command' \@\'['Calamity.Types.Model.User.User'] "utest" $ \\ctx u \-\> do+--     'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx $ "got user: " '<>' 'TextShow.showtl' u+--   'group' "admin" $ do+--     'command' \@'[] "bye" $ \\ctx -> do+--       'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx "bye!"+--       'Calamity.Client.stopBot'+-- @

@@ -0,0 +1,15 @@+-- | Named boolean for determining if something is an alias or not+module Calamity.Commands.AliasType+  ( AliasType (..),+  )+where++import GHC.Generics (Generic)+import TextShow (TextShow)+import qualified TextShow.Generic as TSG++data AliasType+  = Alias+  | Original+  deriving (Eq, Enum, Show, Generic)+  deriving (TextShow) via TSG.FromGeneric AliasType

@@ -0,0 +1,51 @@+-- | Command invokation preconditions+module Calamity.Commands.Check+    ( Check(..)+    , buildCheck+    , buildCheckPure+    , runCheck ) where++import {-# SOURCE #-} Calamity.Commands.Context+import           Calamity.Commands.Error+import           Calamity.Internal.RunIntoIO+import           Calamity.Internal.Utils++import           Control.Lens                hiding ( (<.>), Context )++import           Data.Generics.Labels        ()+import           Data.Maybe+import qualified Data.Text                   as S+import qualified Data.Text.Lazy              as L++import           GHC.Generics++import qualified Polysemy                    as P++-- | A check for a command.+--+-- Every check for a command must return Nothing for the command to be run.+data Check = MkCheck+  { name     :: S.Text+    -- ^ The name of the check.+  , callback :: Context -> IO (Maybe L.Text)+    -- ^ The callback for the check, returns Nothing if it passes, otherwise+    -- returns the reason for it not passing.+  }+  deriving ( Generic )++-- | Given the name of a check and a callback in the 'P.Sem' monad, build a+-- check by transforming the Polysemy action into an IO action.+buildCheck :: P.Member (P.Final IO) r => S.Text -> (Context -> P.Sem r (Maybe L.Text)) -> P.Sem r Check+buildCheck name cb = do+  cb' <- bindSemToIO cb+  let cb'' = fromMaybe (Just "failed internally") <.> cb'+  pure $ MkCheck name cb''++-- | Given the name of a check and a pure callback function, build a check.+buildCheckPure :: S.Text -> (Context -> Maybe L.Text) -> Check+buildCheckPure name cb = MkCheck name (pure . cb)++-- | Given an invokation 'Context', run a check and transform the result into an+-- @'Either' 'CommandError' ()@.+runCheck :: P.Member (P.Embed IO) r => Context -> Check -> P.Sem r (Either CommandError ())+runCheck ctx chk = P.embed (callback chk ctx) <&> justToEither . (CheckError (chk ^. #name) <$>)

@@ -0,0 +1,71 @@+-- | Commands and stuff+module Calamity.Commands.Command+    ( Command(..) ) where++import           Calamity.Commands.Check+import           Calamity.Commands.Context+import           Calamity.Commands.Error+import           Calamity.Commands.Group++import           Control.Lens              hiding ( (<.>), Context )++import           Data.List.NonEmpty        ( NonEmpty )+import           Data.Text                 as S+import           Data.Text.Lazy            as L++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic          as TSG+import qualified Data.List.NonEmpty as NE++-- | A command+data Command = forall a. Command+  { names    :: NonEmpty S.Text+  , parent   :: Maybe Group+  , hidden   :: Bool+    -- ^ If this command is hidden+  , checks   :: [Check]+    -- ^ A list of checks that must pass for this command to be invoked+  , params   :: [S.Text]+    -- ^ A list of the parameters the command takes, only used for constructing+    -- help messages.+  , help     :: Context -> L.Text+    -- ^ A function producing the \'help\' for the command.+  , parser   :: Context -> IO (Either CommandError a)+    -- ^ A function that parses the context for the command, producing the input+    -- @a@ for the command.+  , callback :: (Context, a) -> IO (Maybe L.Text)+    -- ^ A function that given the context and the input (@a@) of the command,+    -- performs the action of the command.+  }++data CommandS = CommandS+  { names  :: NonEmpty S.Text+  , params :: [S.Text]+  , parent :: Maybe S.Text+  , checks :: [S.Text]+  , hidden :: Bool+  }+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric CommandS++instance Show Command where+  showsPrec d Command {names, params, parent, checks, hidden} =+    showsPrec d $+      CommandS+        names+        params+        (NE.head <$> parent ^? _Just . #names)+        (checks ^.. traverse . #name)+        hidden++instance TextShow Command where+  showbPrec d Command {names, params, parent, checks, hidden} =+    showbPrec d $+      CommandS+        names+        params+        (NE.head <$> parent ^? _Just . #names)+        (checks ^.. traverse . #name)+        hidden

@@ -0,0 +1,11 @@+-- | Commands and stuff+module Calamity.Commands.Command+    ( Command+    ) where++import TextShow++data Command++instance Show Command+instance TextShow Command

@@ -0,0 +1,212 @@+-- | Command utilities+module Calamity.Commands.CommandUtils+    ( TypedCommandC+    , CommandForParsers+    , buildCommand+    , buildCommand'+    , buildParser+    , buildCallback+    , runCommand+    , invokeCommand+    , groupPath+    , commandPath+    , commandParams ) where++import           Calamity.Commands.Check+import           Calamity.Commands.Command+import           Calamity.Commands.Context+import           Calamity.Commands.Error+import           Calamity.Commands.Group+import           Calamity.Commands.Parser+import           Calamity.Internal.RunIntoIO+import           Calamity.Internal.Utils++import           Control.Lens                hiding ( (<.>), Context )+import           Control.Monad++import           Data.Foldable+import           Data.Kind+import           Data.List.NonEmpty          ( NonEmpty(..) )+import qualified Data.List.NonEmpty          as NE+import           Data.Maybe+import           Data.Text                   as S+import           Data.Text.Lazy              as L++import qualified Polysemy                    as P+import qualified Polysemy.Error              as P+import qualified Polysemy.Fail               as P++groupPath :: Group -> [S.Text]+groupPath Group { names, parent } = maybe [] groupPath parent ++ [NE.head names]++commandPath :: Command -> [S.Text]+commandPath Command { names, parent } = maybe [] groupPath parent ++ [NE.head names]++-- | Format a command's parameters+commandParams :: Command -> L.Text+commandParams Command { params } = L.fromStrict $ S.intercalate ", " params++-- | Given the properties of a 'Command' with the @parser@ and @callback@ in the+-- 'P.Sem' monad, build a command by transforming the Polysemy actions into IO+-- actions.+buildCommand' :: P.Member (P.Final IO) r+              => NonEmpty S.Text+              -- ^ The name (and aliases) of the command+              -> Maybe Group+              -- ^ The parent group of the command+              -> Bool+              -- ^ If the command is hidden+              -> [Check]+              -- ^ The checks for the command+              -> [S.Text]+              -- ^ The names of the command's parameters+              -> (Context -> L.Text)+              -- ^ The help generator for this command+              -> (Context -> P.Sem r (Either CommandError a))+              -- ^ The parser for this command+              -> ((Context, a) -> P.Sem (P.Fail ': r) ())+              -- ^ The callback for this command+              -> P.Sem r Command+buildCommand' names@(name :| _) parent hidden checks params help parser cb = do+  cb' <- buildCallback cb+  parser' <- buildParser name parser+  pure $ Command names parent hidden checks params help parser' cb'++-- | Given the properties of a 'Command', a callback, and a type level list of+-- the parameters, build a command by constructing a parser and wiring it up to+-- the callback.+--+-- ==== Examples+--+-- Building a command that bans a user by id.+--+-- @+-- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneStarConcat' 'S.Text')]+--    "ban" 'Nothing' [] ('const' "Ban a user") $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+--      'Just' guild -> do+--        'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r)+--        'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)+--      'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds."+-- @+buildCommand :: forall ps r.+             (P.Member (P.Final IO) r, TypedCommandC ps r)+             => NonEmpty S.Text+             -- ^ The name (and aliases) of the command+             -> Maybe Group+             -- ^ The parent group of the command+             -> Bool+             -- ^ If the command is hidden+             -> [Check]+             -- ^ The checks for the command+             -> (Context -> L.Text)+             -- ^ The help generator for this command+             -> (Context -> CommandForParsers ps r)+             -- ^ The callback foor this command+             -> P.Sem r Command+buildCommand names parent hidden checks help command =+  let (parser, cb) = buildTypedCommand @ps command+  in buildCommand' names parent hidden checks (paramNames @ps @r) help parser cb++-- | Given the name of the command the parser is for and a parser function in+-- the 'P.Sem' monad, build a parser by transforming the Polysemy action into an+-- IO action.+buildParser :: P.Member (P.Final IO) r+            => S.Text+            -> (Context -> P.Sem r (Either CommandError a))+            -> P.Sem r (Context -> IO (Either CommandError a))+buildParser name cb = do+  cb' <- bindSemToIO cb+  let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> name) "failed internally") <$> cb' ctx+  pure cb''++-- | Given a callback for a command in the 'P.Sem' monad, build a command callback by+-- transforming the Polysemy action into an IO action.+buildCallback+  :: P.Member (P.Final IO) r => ((Context, a) -> P.Sem (P.Fail ': r) ()) -> P.Sem r ((Context, a) -> IO (Maybe L.Text))+buildCallback cb = do+  cb' <- bindSemToIO (\x -> P.runFail (cb x) <&> \case+                        Left e  -> Just $ L.pack e+                        Right _ -> Nothing)+  let cb'' = fromMaybe (Just "failed internally") <.> cb'+  pure cb''++-- | Given an invokation 'Context', run a command. This does not perform the command's checks.+runCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ())+runCommand ctx Command { names = name :| _, parser, callback } = P.embed (parser ctx) >>= \case+  Left e   -> pure $ Left e+  Right p' -> P.embed (callback (ctx, p')) <&> justToEither . (InvokeError name <$>)++-- | Given an invokation 'Context', first run all of the command's checks, then+-- run the command if they all pass.+invokeCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ())+invokeCommand ctx cmd@Command { checks } = P.runError $ do+  for_ checks (P.fromEither <=< runCheck ctx)+  P.fromEither =<< runCommand ctx cmd++type CommandSemType r = P.Sem (P.Fail ': r) ()++-- | Some constraints used for making parameter typed commands work+type TypedCommandC ps r =+  ( ApplyTupRes (ParserResult (ListToTup ps)) (CommandSemType r) ~ CommandForParsers ps r+  , Parser (ListToTup ps) r+  , ApplyTup (ParserResult (ListToTup ps)) (CommandSemType r)+  , ParamNamesForParsers ps r+  )++buildTypedCommand+  :: forall (ps :: [Type]) a r.+  (TypedCommandC ps r, a ~ ParserResult (ListToTup ps))+  => (Context -> CommandForParsers ps r)+  -> ( Context+         -> P.Sem r (Either CommandError a)+     , (Context, a)+         -> P.Sem (P.Fail ': r) ())+buildTypedCommand cmd = let parser ctx = buildTypedCommandParser @ps ctx (ctx ^. #unparsedParams)+                            consumer (ctx, r) = applyTup (cmd ctx) r+                        in (parser, consumer)++class ParamNamesForParsers (ps :: [Type]) r where+  paramNames :: [S.Text]++instance ParamNamesForParsers '[] r where+  paramNames = []++instance (Parser x r, ParamNamesForParsers xs r) => ParamNamesForParsers (x : xs) r where+  paramNames = (parserName @x @r : paramNames @xs @r)++class ApplyTup a b where+  type ApplyTupRes a b++  applyTup :: ApplyTupRes a b -> a -> b++instance ApplyTup as b => ApplyTup (a, as) b where+  type ApplyTupRes (a, as) b = a -> ApplyTupRes as b++  applyTup f (a, as) = applyTup (f a) as++instance ApplyTup () b where+  type ApplyTupRes () b = b++  applyTup r () = r++buildTypedCommandParser :: forall (ps :: [Type]) r. Parser (ListToTup ps) r => Context -> L.Text -> P.Sem r (Either CommandError (ParserResult (ListToTup ps)))+buildTypedCommandParser ctx t = (runCommandParser ctx t $ parse @(ListToTup ps) @r) <&> \case+  Right r -> Right r+  Left (n, e)  -> Left $ ParseError n e++type family ListToTup (ps :: [Type]) where+  ListToTup '[] = ()+  ListToTup (x ': xs) = (x, ListToTup xs)++-- | Transform a type level list of types implementing the 'Parser' typeclass into+-- the type a command callback matching those parameters should be.+--+-- As an example:+--+-- @+-- 'CommandForParsers' [ 'L.Text', 'Calamity.Types.Snowflake' 'Calamity.Types.User', 'Calamity.Commands.Parser.Named' "something" 'L.Text' ] r ~+--   ('L.Text' -> 'Calamity.Types.Snowflake' 'Calamity.Types.User' -> 'L.Text' -> 'P.Sem' r ('P.Fail' ': r) ())+-- @+type family CommandForParsers (ps :: [Type]) r where+  CommandForParsers '[] r = P.Sem (P.Fail ': r) ()+  CommandForParsers (x ': xs) r = ParserResult x -> CommandForParsers xs r

@@ -0,0 +1,42 @@+-- | Command invokation context+module Calamity.Commands.Context+    ( Context(..) ) where++import {-# SOURCE #-} Calamity.Commands.Command+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake+import           Calamity.Types.Tellable++import qualified Data.Text.Lazy               as L++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic             as TSG++-- | Invokation context for commands+data Context = Context+  { message        :: Message+    -- ^ The message that the command was invoked from+  , guild          :: Maybe Guild+    -- ^ If the command was sent in a guild, this will be present+  , member         :: Maybe Member+    -- ^ The member that invoked the command, if in a guild+  , channel        :: Channel+    -- ^ The channel the command was invoked from+  , user           :: User+    -- ^ The user that invoked the command+  , command        :: Command+    -- ^ The command that was invoked+  , prefix         :: L.Text+    -- ^ The prefix that was used to invoke the command+  , unparsedParams :: L.Text+    -- ^ The message remaining after consuming the prefix+  }+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Context++instance Tellable Context where+  getChannel Context { channel } = pure . getID $ channel

@@ -0,0 +1,10 @@+-- | Command invokation context+module Calamity.Commands.Context+    ( Context ) where++import           TextShow++data Context++instance Show Context+instance TextShow Context

@@ -0,0 +1,361 @@+{-# LANGUAGE RecursiveDo #-}++-- | A DSL for generating commands and groups+module Calamity.Commands.Dsl+    ( -- * Commands DSL+      -- $dslTutorial+      command+    , command'+    , commandA+    , commandA'+    , hide+    , help+    , requires+    , requires'+    , requiresPure+    , group+    , group'+    , groupA+    , groupA'+    , DSLState+    , raiseDSL+    , fetchHandler ) where++import           Calamity.Commands.AliasType+import           Calamity.Commands.Check+import           Calamity.Commands.Command     hiding ( help )+import           Calamity.Commands.CommandUtils+import           Calamity.Commands.Context     hiding ( command )+import           Calamity.Commands.Error+import           Calamity.Commands.Group       hiding ( help )+import           Calamity.Commands.Handler+import           Calamity.Internal.LocalWriter++import qualified Data.HashMap.Lazy             as LH+import qualified Data.Text                     as S+import qualified Data.Text.Lazy                as L++import qualified Polysemy                      as P+import qualified Polysemy.Fail                 as P+import qualified Polysemy.Tagged               as P+import qualified Polysemy.Fixpoint             as P+import qualified Polysemy.Reader               as P+import Data.List.NonEmpty (NonEmpty(..))++-- $dslTutorial+--+-- This module provides a way of constructing bot commands in a declarative way.+--+-- The main component of this is the 'command' function, which takes a+-- type-level list of command parameters, the name, and the callback and+-- produces a command. There are also the alternatives 'command'', 'commandA'+-- and 'commandA'', for when you want to handle parsing of the input yourself,+-- and/or want aliases of the command.+--+-- The functions: 'hide', 'help', 'requires', and 'group' can be used to change+-- attributes of any commands declared inside the monadic action passed to them,+-- for example:+--+-- @+-- 'hide' '$' do+--   'command' \@'[] "test" \\ctx -> 'pure' ()+-- @+--+-- In the above block, any command declared inside 'hide' will have it's+-- \'hidden\' flag set and will not be shown by the default help command:+-- 'Calamity.Commands.Help.helpCommand'+--+-- The 'Calamity.Commands.Help.helpCommand' function can be used to create a+-- help command for the commands DSL action it is used in, read it's doc page+-- for more information on how it functions.+--+-- The 'Calamity.Commands.Utils.addCommands' function creates the command+-- handler for the commands registered in the passed action, it is what reads a+-- message to determine what command was invoked. It should be used to register the+-- commands with the bot by using it inside the setup action, for example:+--+-- @+-- 'Calamity.Client.runBotIO' ('Calamity.BotToken' token)+--   $ 'Calamity.Commands.Utils.addCommands' $ do+--     'Calamity.Commands.Help.helpCommand'+--     'Calamity.Commands.Dsl.command' \@'[] "test" \\ctx ->+--       'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' \@'L.Text' ctx "hi"+-- @+--+-- The above block will create a command with no parameters named \'test\',+-- along with a help command.++type DSLState r =+  ( LocalWriter (LH.HashMap S.Text (Command, AliasType))+      ': LocalWriter (LH.HashMap S.Text (Group, AliasType))+      ': P.Reader (Maybe Group)+      ': P.Tagged "hidden" (P.Reader Bool)+      ': P.Reader (Context -> L.Text)+      ': P.Tagged "original-help" (P.Reader (Context -> L.Text))+      ': P.Reader [Check]+      ': P.Reader CommandHandler+      ': P.Fixpoint+      ': r+  )++raiseDSL :: P.Sem r a -> P.Sem (DSLState r) a+raiseDSL = P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise++-- | Given the command name and parameter names, @parser@ and @callback@ for a+-- command in the 'P.Sem' monad, build a command by transforming the Polysemy+-- actions into IO actions. Then register the command.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+command'+  :: P.Member (P.Final IO) r+  => S.Text+  -- ^ The name of the command+  -> [S.Text]+  -- ^ The names of the command's parameters+  -> (Context -> P.Sem r (Either CommandError a))+  -- ^ The parser for this command+  -> ((Context, a) -> P.Sem (P.Fail ': r) ())+  -- ^ The callback for this command+  -> P.Sem (DSLState r) Command+command' name params parser cb = commandA' name [] params parser cb++-- | Given the command name, aliases, and parameter names, @parser@ and+-- @callback@ for a command in the 'P.Sem' monad, build a command by+-- transforming the Polysemy actions into IO actions. Then register the command.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+commandA'+  :: P.Member (P.Final IO) r+  => S.Text+  -- ^ The name of the command+  -> [S.Text]+  -- ^ The aliases for the command+  -> [S.Text]+  -- ^ The names of the command's parameters+  -> (Context -> P.Sem r (Either CommandError a))+  -- ^ The parser for this command+  -> ((Context, a) -> P.Sem (P.Fail ': r) ())+  -- ^ The callback for this command+  -> P.Sem (DSLState r) Command+commandA' name aliases params parser cb = do+  parent <- P.ask @(Maybe Group)+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check]+  help' <- P.ask @(Context -> L.Text)+  cmd <- raiseDSL $ buildCommand' (name :| aliases) parent hidden checks params help' parser cb+  ltell $ LH.singleton name (cmd, Original)+  ltell $ LH.fromList [(name, (cmd, Alias)) | name <- aliases]+  pure cmd++-- | Given the name of a command and a callback, and a type level list of+-- the parameters, build and register a command.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+--+-- Command parameters are parsed by first invoking+-- 'Calamity.Commands.Parser.parse' for the first+-- 'Calamity.Commands.Parser.Parser', then running the next parser on the+-- remaining input, and so on.+--+-- ==== Examples+--+-- Building a command that bans a user by id.+--+-- @+-- 'command' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),+--                'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneStarConcat' 'S.Text')]+--    "ban" $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+--      'Just' guild -> do+--        'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r)+--        'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)+--      'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds."+-- @+command :: forall ps r.+        ( P.Member (P.Final IO) r,+          TypedCommandC ps r)+        => S.Text+        -- ^ The name of the command+        -> (Context -> CommandForParsers ps r)+        -- ^ The callback for this command+        -> P.Sem (DSLState r) Command+command name cmd = commandA @ps name [] cmd++-- | Given the name and aliases of a command and a callback, and a type level list of+-- the parameters, build and register a command.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+--+-- ==== Examples+--+-- Building a command that bans a user by id.+--+-- @+-- 'commandA' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'),+--                'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneStarConcat' 'S.Text')]+--    "ban" [] $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of+--      'Just' guild -> do+--        'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r)+--        'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r)+--      'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds."+-- @+commandA :: forall ps r.+        ( P.Member (P.Final IO) r,+          TypedCommandC ps r)+        => S.Text+        -- ^ The name of the command+        -> [S.Text]+        -- ^ The aliases for the command+        -> (Context -> CommandForParsers ps r)+        -- ^ The callback for this command+        -> P.Sem (DSLState r) Command+commandA name aliases cmd = do+  parent <- P.ask @(Maybe Group)+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check]+  help' <- P.ask @(Context -> L.Text)+  cmd' <- raiseDSL $ buildCommand @ps (name :| aliases) parent hidden checks help' cmd+  ltell $ LH.singleton name (cmd', Original)+  ltell $ LH.fromList [(name, (cmd', Alias)) | name <- aliases]+  pure cmd'++-- | Set the visibility of any groups or commands registered inside the given+-- action to hidden.+hide :: P.Member (P.Tagged "hidden" (P.Reader Bool)) r+     => P.Sem r a+     -> P.Sem r a+hide = P.tag @"hidden" . P.local @Bool (const True) . P.raise++-- | Set the help for any groups or commands registered inside the given action.+help :: P.Member (P.Reader (Context -> L.Text)) r+     => (Context -> L.Text)+     -> P.Sem r a+     -> P.Sem r a+help = P.local . const++-- | Add to the list of checks for any commands registered inside the given+-- action.+requires :: [Check]+         -> P.Sem (DSLState r) a+         -> P.Sem (DSLState r) a+requires = P.local . (<>)++-- | Construct a check and add it to the list of checks for any commands+-- registered inside the given action.+--+-- Refer to 'Calamity.Commands.Check.Check' for more info on checks.+requires' :: P.Member (P.Final IO) r+          => S.Text+          -- ^ The name of the check+          -> (Context -> P.Sem r (Maybe L.Text))+          -- ^ The callback for the check+          -> P.Sem (DSLState r) a+          -> P.Sem (DSLState r) a+requires' name cb m = do+  check <- raiseDSL $ buildCheck name cb+  requires [check] m++-- | Construct some pure checks and add them to the list of checks for any+-- commands registered inside the given action.+--+-- Refer to 'Calamity.Commands.Check.Check' for more info on checks.+requiresPure :: [(S.Text, Context -> Maybe L.Text)]+             -- A list of check names and check callbacks+             -> P.Sem (DSLState r) a+             -> P.Sem (DSLState r) a+requiresPure checks = requires $ map (uncurry buildCheckPure) checks++-- | Construct a group and place any commands registered in the given action+-- into the new group.+--+-- This also resets the @help@ function back to it's original value, use+-- 'group'' if you don't want that (i.e. your help function is context aware).+group :: P.Member (P.Final IO) r+      => S.Text+      -- ^ The name of the group+      -> P.Sem (DSLState r) a+      -> P.Sem (DSLState r) a+group name m = groupA name [] m++-- | Construct a group with aliases and place any commands registered in the+-- given action into the new group.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+--+-- This also resets the @help@ function back to it's original value, use+-- 'group'' if you don't want that (i.e. your help function is context aware).+groupA :: P.Member (P.Final IO) r+       => S.Text+       -- ^ The name of the group+       -> [S.Text]+       -- ^ The aliases of the group+       -> P.Sem (DSLState r) a+       -> P.Sem (DSLState r) a+groupA name aliases m = mdo+  parent <- P.ask @(Maybe Group)+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check]+  help'  <- P.ask @(Context -> L.Text)+  origHelp <- fetchOrigHelp+  let group' = Group (name :| aliases) parent hidden commands children help' checks+  (children, (commands, res)) <- llisten @(LH.HashMap S.Text (Group, AliasType)) $+                                 llisten @(LH.HashMap S.Text (Command, AliasType)) $+                                 P.local @(Maybe Group) (const $ Just group') $+                                 P.local @(Context -> L.Text) (const origHelp) m+  ltell $ LH.singleton name (group', Original)+  ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases]+  pure res++fetchOrigHelp :: P.Member (P.Tagged "original-help" (P.Reader (Context -> L.Text))) r => P.Sem r (Context -> L.Text)+fetchOrigHelp = P.tag P.ask++-- | Construct a group and place any commands registered in the given action+-- into the new group.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+--+-- Unlike 'help' this doesn't reset the @help@ function back to it's original+-- value.+group' :: P.Member (P.Final IO) r+         => S.Text+         -- The name of the group+         -> P.Sem (DSLState r) a+         -> P.Sem (DSLState r) a+group' name m = groupA' name [] m++-- | Construct a group with aliases and place any commands registered in the given action+-- into the new group.+--+-- The parent group, visibility, checks, and command help are drawn from the+-- reader context.+--+-- Unlike 'help' this doesn't reset the @help@ function back to it's original+-- value.+groupA' :: P.Member (P.Final IO) r+         => S.Text+         -- ^ The name of the group+         -> [S.Text]+         -- ^ The aliases of the group+         -> P.Sem (DSLState r) a+         -> P.Sem (DSLState r) a+groupA' name aliases m = mdo+  parent <- P.ask @(Maybe Group)+  hidden <- P.tag $ P.ask @Bool+  checks <- P.ask @[Check]+  help'  <- P.ask @(Context -> L.Text)+  let group' = Group (name :| aliases) parent hidden commands children help' checks+  (children, (commands, res)) <- llisten @(LH.HashMap S.Text (Group, AliasType)) $+                                 llisten @(LH.HashMap S.Text (Command, AliasType)) $+                                 P.local @(Maybe Group) (const $ Just group') m+  ltell $ LH.singleton name (group', Original)+  ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases]+  pure res++-- | Retrieve the final command handler for this block+fetchHandler :: P.Sem (DSLState r) CommandHandler+fetchHandler = P.ask

@@ -0,0 +1,21 @@+-- | Command errors+module Calamity.Commands.Error+    ( CommandError(..) ) where++import qualified Data.Text        as S+import qualified Data.Text.Lazy   as L++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic as TSG++data CommandError+  = ParseError S.Text -- ^ The type of the parser+               L.Text -- ^ The reason that parsing failed+  | CheckError S.Text -- ^ The name of the check that failed+               L.Text -- ^ The reason for the check failing+  | InvokeError S.Text -- ^ The name of the command that failed+                L.Text -- ^ The reason for failing+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric CommandError

@@ -0,0 +1,53 @@+-- | Command groups+module Calamity.Commands.Group+    ( Group(..) ) where++import           Calamity.Commands.AliasType+import           Calamity.Commands.Check+import {-# SOURCE #-} Calamity.Commands.Command+import {-# SOURCE #-} Calamity.Commands.Context++import           Control.Lens              hiding ( (<.>), Context )++import qualified Data.HashMap.Lazy         as LH+import qualified Data.Text                 as S+import qualified Data.Text.Lazy            as L++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic          as TSG+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE++-- | A group of commands+data Group = Group+  { names    :: NonEmpty S.Text+  , parent   :: Maybe Group+  , hidden   :: Bool+  , commands :: LH.HashMap S.Text (Command, AliasType)+    -- ^ Any child commands of this group+  , children :: LH.HashMap S.Text (Group, AliasType)+    -- ^ Any child groups of this group+  , help     :: Context -> L.Text+    -- ^ A function producing the \'help' for the group+  , checks   :: [Check]+    -- ^ A list of checks that must pass+  }+  deriving ( Generic )++data GroupS = GroupS+  { names    :: NonEmpty S.Text+  , parent   :: Maybe S.Text+  , commands :: LH.HashMap S.Text (Command, AliasType)+  , children :: LH.HashMap S.Text (Group, AliasType)+  , hidden   :: Bool+  }+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric GroupS++instance Show Group where+  showsPrec d Group {names, parent, commands, children, hidden} = showsPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children hidden++instance TextShow Group where+  showbPrec d Group {names, parent, commands, children, hidden} = showbPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children hidden

@@ -0,0 +1,24 @@+-- | A command handler+module Calamity.Commands.Handler+    ( CommandHandler(..) ) where++import           Calamity.Commands.AliasType+import           Calamity.Commands.Command+import           Calamity.Commands.Group++import qualified Data.HashMap.Lazy         as LH+import qualified Data.Text                 as S++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic          as TSG++data CommandHandler = CommandHandler+  { groups   :: LH.HashMap S.Text (Group, AliasType)+    -- ^ Top level groups+  , commands :: LH.HashMap S.Text (Command, AliasType)+    -- ^ Top level commands+  }+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric CommandHandler

@@ -0,0 +1,193 @@+-- | A default help command implementation+module Calamity.Commands.Help+    ( helpCommand'+    , helpCommand ) where++import           Calamity.Client.Types+import           Calamity.Commands.AliasType+import           Calamity.Commands.Check+import           Calamity.Commands.Command+import           Calamity.Commands.CommandUtils+import           Calamity.Commands.Context+import           Calamity.Commands.Dsl+import           Calamity.Commands.Group+import           Calamity.Commands.Handler+import           Calamity.Internal.LocalWriter+import           Calamity.Types.Tellable++import           Control.Applicative+import           Control.Lens hiding ( Context(..) )+import           Control.Monad++import qualified Data.HashMap.Lazy              as LH+import           Data.List.NonEmpty             ( NonEmpty(..) )+import qualified Data.List.NonEmpty             as NE+import           Data.Maybe                     ( catMaybes )+import qualified Data.Text                      as S+import qualified Data.Text.Lazy                 as L++import qualified Polysemy                       as P+import qualified Polysemy.Fail                  as P+import qualified Polysemy.Reader                as P+import Data.Maybe (mapMaybe)++data CommandOrGroup+  = Command' Command+  | Group' Group [S.Text]++helpCommandHelp :: Context -> L.Text+helpCommandHelp _ = "Show help for a command or group."++helpForCommand :: Context -> Command -> L.Text+helpForCommand ctx (cmd@Command { names, checks, help }) = "```\nUsage: " <> prefix' <> path' <> " " <> params' <> "\n" <>+                                                           aliasesFmt <>+                                                           checksFmt <>+                                                           help ctx <> "\n```"+  where prefix' = ctx ^. #prefix+        path'   = L.unwords . map L.fromStrict $ commandPath cmd+        params' = commandParams cmd+        aliases = map L.fromStrict $ NE.tail names+        checks' = map L.fromStrict . map (^. #name) $ checks+        aliasesFmt = if null aliases then "" else  "Aliases: " <> L.unwords aliases <> "\n"+        checksFmt = if null checks' then "" else "Checks: " <> L.unwords checks' <> "\n\n"++fmtCommandWithParams :: Command -> L.Text+fmtCommandWithParams cmd@Command { names } = formatWithAliases names <> " " <> commandParams cmd++formatWithAliases :: NonEmpty S.Text -> L.Text+formatWithAliases (name :| aliases) = L.fromStrict name <> aliasesFmt+  where+    aliasesFmt = case aliases of+      [] -> ""+      aliases' -> "[" <> L.intercalate "|" (map L.fromStrict aliases') <> "]"++onlyOriginals :: [(a, AliasType)] -> [a]+onlyOriginals = mapMaybe inner+  where inner (_, Alias) = Nothing+        inner (a, Original) = Just a++onlyVisibleC :: [Command] -> [Command]+onlyVisibleC = catMaybes . map notHiddenC++onlyVisibleG :: [Group] -> [Group]+onlyVisibleG = catMaybes . map notHiddenG++helpForGroup :: Context -> Group -> L.Text+helpForGroup ctx grp = "```\nGroup: " <> path' <> "\n" <>+                       aliasesFmt <>+                       checksFmt <>+                       (grp ^. #help) ctx <> "\n" <>+                       groupsMsg <> commandsMsg <> "\n```"+  where path' = L.fromStrict . S.unwords $ groupPath grp+        groups =  onlyVisibleG . onlyOriginals . LH.elems $ grp ^. #children+        commands = onlyVisibleC .onlyOriginals . LH.elems $ grp ^. #commands+        groupsFmt = map formatWithAliases (groups ^.. traverse . #names)+        groupsMsg = if null groups then "" else "The following child groups exist:\n" <> (L.unlines . map ("- " <>) $ groupsFmt)+        commandsMsg = if null commands then "" else "\nThe following child commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands)+        aliases = map L.fromStrict . NE.tail $ grp ^. #names+        checks' = map L.fromStrict . map (^. #name) $ grp ^. #checks+        aliasesFmt = if null aliases then "" else  "Aliases: " <> L.unwords aliases <> "\n"+        checksFmt = if null checks' then "" else "Checks: " <> L.unwords checks' <> "\n\n"++rootHelp :: CommandHandler -> L.Text+rootHelp handler = "```\n" <> groupsMsg <> commandsMsg <> "\n```"+  where groups =  onlyVisibleG . onlyOriginals . LH.elems $ handler ^. #groups+        commands = onlyVisibleC . onlyOriginals . LH.elems $ handler ^. #commands+        groupsFmt = map formatWithAliases (groups ^.. traverse . #names)+        groupsMsg = if null groups then "" else "The following groups exist:\n" <> (L.unlines . map ("- " <>) $ groupsFmt)+        commandsMsg = if null commands then "" else "\nThe following commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands)++helpCommandCallback :: BotC r => CommandHandler -> Context -> [S.Text] -> P.Sem (P.Fail ': r) ()+helpCommandCallback handler ctx path = do+  case findCommandOrGroup handler path of+    Just (Command' cmd@Command { names }) ->+      void $ tell @L.Text ctx $ "Help for command `" <> L.fromStrict (NE.head names) <> "`: \n" <> helpForCommand ctx cmd+    Just (Group' grp@Group { names } remainingPath) ->+      let failedMsg = if null remainingPath+            then ""+            else "No command or group with the path: `" <> L.fromStrict (S.unwords remainingPath) <> "` exists for the group: `" <> L.fromStrict (NE.head names) <> "`\n"+      in void $ tell @L.Text ctx $ failedMsg <> "Help for group `" <> L.fromStrict (NE.head names) <> "`: \n" <> helpForGroup ctx grp+    Nothing -> let failedMsg = if null path+                     then ""+                     else "No command or group with the path: `" <> L.fromStrict (S.unwords path) <> "` was found.\n"+               in void $ tell @L.Text ctx $ failedMsg <> rootHelp handler++-- | Given a 'CommandHandler', optionally a parent 'Group', and a list of 'Check's,+-- construct a help command that will provide help for all the commands and+-- groups in the passed 'CommandHandler'.+helpCommand' :: BotC r => CommandHandler -> Maybe Group -> [Check] -> P.Sem r Command+helpCommand' handler parent checks = buildCommand @'[[S.Text]] ("help" :| []) parent False checks helpCommandHelp+  (helpCommandCallback handler)++-- | Create and register the default help command for all the commands+-- registered in the commands DSL this is used in.+--+-- The registered command will have the name \'help\', called with no parameters+-- it will print the top-level groups and commands, for example:+--+-- @+-- The following groups exist:+-- - reanimate+-- - prefix[prefixes]+-- - alias[aliases]+-- - remind[reminder|reminders]+--+-- The following commands exist:+-- - help :[Text]+-- @+--+-- Both commands and groups are listed in the form: @\<name\>[\<alias 0\>|\<alias 1\>]@,+-- commands also have their parameter list shown.+--+-- If a path to a group is passed, the help, aliases, and pre-invokation checks+-- will be listed, along with the subgroups and commands, For example:+--+-- @+-- Help for group remind:+-- Group: remind+-- Aliases: reminder reminders+-- Commands related to making reminders+--+-- The following child commands exist:+-- - list+-- - remove reminder_id:Text+-- - add :KleenePlusConcat Text+-- @+--+-- If a command path is passed, the usage, checks and help for the command are+-- shown, for example:+--+-- @+-- Help for command add:+-- Usage: c!prefix add prefix:Text+-- Checks: prefixLimit guildOnly+--+-- Add a new prefix+-- @+helpCommand :: BotC r => P.Sem (DSLState r) Command+helpCommand = do+  handler <- P.ask @CommandHandler+  parent <- P.ask @(Maybe Group)+  checks <- P.ask @[Check]+  cmd <- raiseDSL $ helpCommand' handler parent checks+  ltell $ LH.singleton "help" (cmd, Original)+  pure cmd++notHiddenC :: Command -> Maybe Command+notHiddenC c@(Command { hidden }) = if hidden then Nothing else Just c++notHiddenG :: Group -> Maybe Group+notHiddenG g@(Group { hidden }) = if hidden then Nothing else Just g++findCommandOrGroup :: CommandHandler -> [S.Text] -> Maybe CommandOrGroup+findCommandOrGroup handler path = go (handler ^. #commands, handler ^. #groups) path+  where go :: (LH.HashMap S.Text (Command, AliasType), LH.HashMap S.Text (Group, AliasType))+           -> [S.Text]+           -> Maybe CommandOrGroup+        go (commands, groups) (x : xs) =+          case LH.lookup x commands of+            Just (notHiddenC -> Just cmd, _) -> Just (Command' cmd)+            _                -> case LH.lookup x groups of+              Just (notHiddenG -> Just group, _) -> go (group ^. #commands, group ^. #children) xs <|> Just (Group' group xs)+              _                                  -> Nothing+        go _ [] = Nothing

@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Command prefix parsing effect+module Calamity.Commands.ParsePrefix+    ( ParsePrefix(..)+    , parsePrefix+    , useConstantPrefix ) where++import           Calamity.Types.Model.Channel.Message++import           Control.Lens++import qualified Data.Text.Lazy                       as L++import qualified Polysemy                             as P++-- | An effect for parsing the prefix of a command.+data ParsePrefix m a where+  -- | Parse a prefix in a message, returning a tuple of @(prefix, remaining message)@+  ParsePrefix :: Message -> ParsePrefix m (Maybe (L.Text, L.Text))++P.makeSem ''ParsePrefix++-- | A default interpretation for 'ParsePrefix' that uses a single constant prefix.+useConstantPrefix :: L.Text -> P.Sem (ParsePrefix ': r) a -> P.Sem r a+useConstantPrefix pre = P.interpret (\case+                                       ParsePrefix m -> pure ((pre, ) <$> L.stripPrefix pre (m ^. #content)))

@@ -0,0 +1,360 @@+-- | Something that can parse user input+module Calamity.Commands.Parser+    ( Parser(..)+    , Named+    , KleeneStarConcat+    , KleenePlusConcat+    , ParserEffs+    , runCommandParser ) where++import           Calamity.Cache.Eff+import           Calamity.Commands.Context+import           Calamity.Types.Model.Channel  ( Channel, GuildChannel )+import           Calamity.Types.Model.Guild    ( Emoji, RawEmoji(..), Partial(PartialEmoji), Guild, Member, Role )+import           Calamity.Types.Model.User     ( User )+import           Calamity.Types.Snowflake+import           Calamity.Types.Partial++import           Control.Lens                  hiding ( Context )+import           Control.Monad+import           Control.Monad.Trans           ( lift )++import           Data.Char                     ( isSpace )+import           Data.Kind+import           Data.List.NonEmpty            ( NonEmpty(..) )+import           Data.Maybe                    ( isJust )+import           Data.Semigroup+import qualified Data.Text                     as S+import qualified Data.Text.Lazy                as L+import           Data.Typeable++import           GHC.Generics                  ( Generic )+import           GHC.TypeLits                  ( KnownSymbol, Symbol, symbolVal )++import qualified Polysemy                      as P+import qualified Polysemy.Error                as P+import qualified Polysemy.Reader               as P+import qualified Polysemy.State                as P++import           Text.Megaparsec               hiding ( parse )+import           Text.Megaparsec.Char+import           Text.Megaparsec.Error.Builder ( errFancy, fancy )+import Text.Megaparsec.Char.Lexer (float, decimal, signed)+import Numeric.Natural (Natural)++data SpannedError = SpannedError L.Text !Int !Int+  deriving ( Show, Eq, Ord )++showTypeOf :: forall a. Typeable a => String+showTypeOf = show . typeRep $ Proxy @a++data ParserState = ParserState+  { off :: Int+  , msg :: L.Text+  }+  deriving ( Show, Generic )++type ParserEffs r = P.State ParserState ': P.Error (S.Text, L.Text) ': P.Reader Context ': r+type ParserCtxE r = P.Reader Context ': r++runCommandParser :: Context -> L.Text -> P.Sem (ParserEffs r) a -> P.Sem r (Either (S.Text, L.Text) a)+runCommandParser ctx t = P.runReader ctx . P.runError . P.evalState (ParserState 0 t)++class Typeable a => Parser (a :: Type) r where+  type ParserResult a++  type ParserResult a = a++  parserName :: S.Text+  default parserName :: S.Text+  parserName = ":" <> S.pack (showTypeOf @a)++  parse :: P.Sem (ParserEffs r) (ParserResult a)++-- | A named parameter, used to attach the name @s@ to a type in the command's+-- help output+data Named (s :: Symbol) (a :: Type)++instance (KnownSymbol s, Parser a r) => Parser (Named s a) r where+  type ParserResult (Named s a) = ParserResult a++  parserName = (S.pack . symbolVal $ Proxy @s) <> parserName @a @r++  parse = mapE (_1 .~ parserName @(Named s a) @r) $ parse @a @r++mapE :: P.Member (P.Error e) r => (e -> e) -> P.Sem r a -> P.Sem r a+mapE f m = P.catch m (P.throw . f)++parseMP :: S.Text -> ParsecT SpannedError L.Text (P.Sem (ParserCtxE r)) a -> P.Sem (ParserEffs r) a+parseMP n m = do+  s <- P.get+  res <- P.raise . P.raise $ runParserT (skipN (s ^. #off) *> trackOffsets (space *> m)) "" (s ^. #msg)+  case res of+    Right (a, offset) -> do+      P.modify (#off +~ offset)+      pure a+    Left s  -> P.throw (n, L.pack $ errorBundlePretty s)++instance Parser L.Text r where+  parse = parseMP (parserName @L.Text) item++instance Parser S.Text r where+  parse = parseMP (parserName @S.Text) (L.toStrict <$> item)++instance Parser Integer r where+  parse = parseMP (parserName @Integer) (signed mempty decimal)++instance Parser Natural r where+  parse = parseMP (parserName @Natural) decimal++instance Parser Int r where+  parse = parseMP (parserName @Int) (signed mempty decimal)++instance Parser Word r where+  parse = parseMP (parserName @Word) decimal++instance Parser Float r where+  parse = parseMP (parserName @Float) (signed mempty (try float <|> decimal))++instance Parser a r => Parser (Maybe a) r where+  type ParserResult (Maybe a) = Maybe (ParserResult a)++  parse = P.catch (Just <$> parse @a) (const $ pure Nothing)+++instance (Parser a r, Parser b r) => Parser (Either a b) r where+  type ParserResult (Either a b) = Either (ParserResult a) (ParserResult b)++  parse = do+    l <- parse @(Maybe a) @r+    case l of+      Just l' -> pure (Left l')+      Nothing ->+        Right <$> parse @b @r++instance Parser a r => Parser [a] r where+  type ParserResult [a] = [ParserResult a]++  parse = go []+    where go :: [ParserResult a] -> P.Sem (ParserEffs r) [ParserResult a]+          go l = P.catch (Just <$> parse @a) (const $ pure Nothing) >>= \case+            Just a -> go $ l ++ [a]+            Nothing -> pure l++instance (Parser a r, Typeable a) => Parser (NonEmpty a) r where+  type ParserResult (NonEmpty a) = NonEmpty (ParserResult a)++  parse = do+    a <- parse @a+    as <- parse @[a]+    pure $ a :| as++-- | A parser that consumes zero or more of @a@ then concatenates them together.+--+-- @'KleeneStarConcat' 'L.Text'@ therefore consumes all remaining input.+data KleeneStarConcat (a :: Type)++instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneStarConcat a) r where+  type ParserResult (KleeneStarConcat a) = ParserResult a++  parse = mconcat <$> parse @[a]++instance {-# OVERLAPS #-}Parser (KleeneStarConcat L.Text) r where+  type ParserResult (KleeneStarConcat L.Text) = ParserResult L.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleeneStarConcat L.Text)) manySingle++instance {-# OVERLAPS #-}Parser (KleeneStarConcat S.Text) r where+  type ParserResult (KleeneStarConcat S.Text) = ParserResult S.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleeneStarConcat S.Text)) (L.toStrict <$> manySingle)++-- | A parser that consumes one or more of @a@ then concatenates them together.+--+-- @'KleenePlusConcat' 'L.Text'@ therefore consumes all remaining input.+data KleenePlusConcat (a :: Type)++instance (Semigroup (ParserResult a), Parser a r) => Parser (KleenePlusConcat a) r where+  type ParserResult (KleenePlusConcat a) = ParserResult a++  parse = sconcat <$> parse @(NonEmpty a)++instance {-# OVERLAPS #-}Parser (KleenePlusConcat L.Text) r where+  type ParserResult (KleenePlusConcat L.Text) = ParserResult L.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleenePlusConcat L.Text)) someSingle++instance {-# OVERLAPS #-}Parser (KleenePlusConcat S.Text) r where+  type ParserResult (KleenePlusConcat S.Text) = ParserResult S.Text++  -- consume rest on text just takes everything remaining+  parse = parseMP (parserName @(KleenePlusConcat S.Text)) (L.toStrict <$> someSingle)++instance Typeable (Snowflake a) => Parser (Snowflake a) r where+  parse = parseMP (parserName @(Snowflake a)) snowflake++-- | Accepts both plain IDs and mentions+instance {-# OVERLAPS #-}Parser (Snowflake User) r where+  parse = parseMP (parserName @(Snowflake User)) (try (ping "@") <|> snowflake)++-- | Accepts both plain IDs and mentions+instance {-# OVERLAPS #-}Parser (Snowflake Member) r where+  parse = parseMP (parserName @(Snowflake Member)) (try (ping "@") <|> snowflake)++-- | Accepts both plain IDs and mentions+instance {-# OVERLAPS #-}Parser (Snowflake Channel) r where+  parse = parseMP (parserName @(Snowflake Channel)) (try (ping "#") <|> snowflake)++-- | Accepts both plain IDs and mentions+instance {-# OVERLAPS #-}Parser (Snowflake Role) r where+  parse = parseMP (parserName @(Snowflake Role)) (try (ping "@&") <|> snowflake)++-- | Accepts both plain IDs and uses of emoji+instance {-# OVERLAPS #-}Parser (Snowflake Emoji) r where+  parse = parseMP (parserName @(Snowflake Emoji)) (try emoji <|> snowflake)++-- mapParserMaybe :: Stream s => ParsecT SpannedError s m a -> Text -> (a -> Maybe b) -> ParsecT SpannedError s m b+-- mapParserMaybe m e f = do+--   offs <- getOffset+--   r <- f <$> m+--   offe <- getOffset+--   case r of+--     Just r' -> pure r'+--     _       -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe++mapParserMaybeM :: (Monad m, Stream s) => ParsecT SpannedError s m a -> L.Text -> (a -> m (Maybe b)) -> ParsecT SpannedError s m b+mapParserMaybeM m e f = do+  offs <- getOffset+  r <- m >>= lift . f+  offe <- getOffset+  case r of+    Just r' -> pure r'+    Nothing -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe++-- | Parser for members in the guild the command was invoked in, this only looks+-- in the cache. Use @'Snowflake' 'Member'@ and use+-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http.+instance Parser Member r where+  parse = parseMP (parserName @Member) $ mapParserMaybeM (try (ping "@") <|> snowflake)+          "Couldn't find a Member with this id"+          (\mid -> do+              ctx <- P.ask+              pure $ ctx ^? #guild . _Just . #members . ix mid)++-- | Parser for users, this only looks in the cache. Use @'Snowflake'+-- 'User'@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow+-- fetching from http.+instance P.Member CacheEff r => Parser User r where+  parse = parseMP (parserName @User @r) $ mapParserMaybeM (try (ping "@") <|> snowflake)+          "Couldn't find a User with this id"+          getUser++-- | Parser for channels in the guild the command was invoked in, this only+-- looks in the cache. Use @'Snowflake' 'Channel'@ and use+-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http.+instance Parser GuildChannel r where+  parse = parseMP (parserName @GuildChannel @r) $ mapParserMaybeM (try (ping "#") <|> snowflake)+          "Couldn't find a GuildChannel with this id"+          (\cid -> do+              ctx <- P.ask+              pure $ ctx ^? #guild . _Just . #channels . ix cid)++-- | Parser for guilds, this only looks in the cache. Use @'Snowflake' 'Guild'@+-- and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching+-- from http.+instance P.Member CacheEff r => Parser Guild r where+  parse = parseMP (parserName @Guild @r) $ mapParserMaybeM snowflake+          "Couldn't find a Guild with this id"+          getGuild++-- | Parser for emojis in the guild the command was invoked in, this only+-- looks in the cache. Use @'Snowflake' 'Emoji'@ and use+-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http.+instance Parser Emoji r where+  parse = parseMP (parserName @Emoji @r) $ mapParserMaybeM (try emoji <|> snowflake)+          "Couldn't find an Emoji with this id"+          (\eid -> do+              ctx <- P.ask+              pure $ ctx ^? #guild . _Just . #emojis . ix eid)++-- | Parses both discord emojis, and unicode emojis+instance Parser RawEmoji r where+  parse = parseMP (parserName @RawEmoji) (try parseCustomEmoji <|> (UnicodeEmoji <$> takeP (Just "A unicode emoji") 1))+    where parseCustomEmoji = CustomEmoji <$> partialEmoji++-- | Parser for roles in the guild the command was invoked in, this only+-- looks in the cache. Use @'Snowflake' 'Role'@ and use+-- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http.+instance Parser Role r where+  parse = parseMP (parserName @Role @r) $ mapParserMaybeM (try (ping "@&") <|> snowflake)+          "Couldn't find an Emoji with this id"+          (\rid -> do+              ctx <- P.ask+              pure $ ctx ^? #guild . _Just . #roles . ix rid)++instance (Parser a r, Parser b r) => Parser (a, b) r where+  type ParserResult (a, b) = (ParserResult a, ParserResult b)++  parse = do+    a <- parse @a+    b <- parse @b+    pure (a, b)++instance Parser () r where+  parse = parseMP (parserName @()) space++instance ShowErrorComponent SpannedError where+  showErrorComponent (SpannedError t _ _) = L.unpack t+  errorComponentLen (SpannedError _ s e) = max 1 $ e - s++skipN :: (Stream s, Ord e) => Int -> ParsecT e s m ()+skipN n = void $ takeP Nothing n++ping :: MonadParsec e L.Text m => L.Text -> m (Snowflake a)+ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">"++ping' :: MonadParsec e L.Text m => m () -> m (Snowflake a)+ping' m = chunk "<" *> m *> snowflake <* chunk ">"++snowflake :: MonadParsec e L.Text m => m (Snowflake a)+snowflake = Snowflake <$> decimal++partialEmoji :: MonadParsec e L.Text m => m (Partial Emoji)+partialEmoji = do+  animated <- isJust <$> (chunk "<" *> optional (chunk "a"))+  name <-  between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") $ not . (== ':'))+  id <- snowflake+  void $ chunk ">"+  pure (PartialEmoji id name animated)++emoji :: MonadParsec e L.Text m => m (Snowflake a)+emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':')))++trackOffsets :: MonadParsec e s m => m a -> m (a, Int)+trackOffsets m = do+  offs <- getOffset+  a <- m+  offe <- getOffset+  pure (a, offe - offs)++item :: MonadParsec e L.Text m => m L.Text+item = try quotedString <|> someNonWS++manySingle :: MonadParsec e s m => m (Tokens s)+manySingle = takeWhileP (Just "Any character") (const True)++someSingle :: MonadParsec e s m => m (Tokens s)+someSingle = takeWhile1P (Just "any character") (const True)++quotedString :: MonadParsec e L.Text m => m L.Text+quotedString = try (between (chunk "'") (chunk "'") (takeWhileP (Just "any character") $ not . (== '\''))) <|>+               between (chunk "\"") (chunk "\"") (takeWhileP (Just "any character") $ not . (== '"'))++-- manyNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s)+-- manyNonWS = takeWhileP (Just "Any Non-Whitespace") (not . isSpace)++someNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s)+someNonWS = takeWhile1P (Just "any non-whitespace") (not . isSpace)

@@ -0,0 +1,194 @@+{-# LANGUAGE RecursiveDo #-}+-- | Command handler utilities+module Calamity.Commands.Utils+    ( addCommands+    , buildCommands+    , buildContext+    , handleCommands+    , findCommand+    , CmdInvokeFailReason(..) ) where++import           Calamity.Cache.Eff+import           Calamity.Metrics.Eff+import           Calamity.Client.Client+import           Calamity.Client.Types+import           Calamity.Commands.AliasType+import           Calamity.Commands.Command+import           Calamity.Commands.CommandUtils+import           Calamity.Commands.Context+import           Calamity.Commands.Dsl+import           Calamity.Commands.Handler+import           Calamity.Commands.Error+import           Calamity.Commands.Group+import           Calamity.Commands.ParsePrefix+import           Calamity.Internal.LocalWriter+import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Control.Lens                   hiding ( Context )+import           Control.Monad++import           Data.Char                      ( isSpace )+import qualified Data.HashMap.Lazy              as LH+import qualified Data.Text                      as S+import qualified Data.Text.Lazy                 as L++import qualified Polysemy                       as P+import qualified Polysemy.Error                 as P+import qualified Polysemy.Fail                  as P+import qualified Polysemy.Tagged                as P+import qualified Polysemy.Fixpoint              as P+import qualified Polysemy.Reader                as P++mapLeft :: (e -> e') -> Either e a -> Either e' a+mapLeft f (Left x)  = Left $ f x+mapLeft _ (Right x) = Right x++data CmdInvokeFailReason+  = NoContext+  | NotFound [L.Text]+  | CommandInvokeError Context CommandError++-- | Construct commands and groups from a command DSL, then registers an event+-- handler on the bot that manages running those commands.+--+--+-- Returns an action to remove the event handler, and the 'CommandHandler' that was constructed.+--+-- ==== Command Resolution+--+-- To determine if a command was invoked, and if so which command was invoked, the following happens:+--+--     1. 'parsePrefix' is invoked, if no prefix is found: stop here.+--+--     2. The input is read a word at a time until a matching command is found,+--        fire the \"command-not-found\" event if not.+--+--     3. A 'Calamity.Commands.Context.Context' is built, and the command invoked.+--+-- ==== Custom Events+--+-- This will fire the following events:+--+--     1. @"command-error" ('Context', 'CommandError')@+--+--         Fired when a command returns an error.+--+--     2. @"command-not-found" ('Calamity.Types.Model.Channel.Message', ['Data.Text.Lazy.Text'])@+--+--         Fired when a valid prefix is used, but the command is not found.+--+--     3. @"command-invoked" 'Context'@+--+--         Fired when a command is successfully invoked.+--+addCommands :: (BotC r, P.Member ParsePrefix r) => P.Sem (DSLState r) a -> P.Sem r (P.Sem r (), CommandHandler, a)+addCommands m = do+  (handler, res) <- buildCommands m+  remove <- react @'MessageCreateEvt $ \msg -> do+    parsePrefix msg >>= \case+      Just (prefix, cmd) -> do+        r <- handleCommands handler msg prefix cmd+        case r of+          Left (CommandInvokeError ctx e) -> fire $ customEvt @"command-error" (ctx, e)+          Left (NotFound path)            -> fire $ customEvt @"command-not-found" (msg, path)+          Left NoContext                  -> pure () -- ignore if context couldn't be built+          Right ctx        -> do+            cmdInvoke <- registerCounter "commands_invoked" [("name", S.unwords $ commandPath (ctx ^. #command))]+            void $ addCounter 1 cmdInvoke+            fire $ customEvt @"command-invoked" ctx+      Nothing -> pure ()+  pure (remove, handler, res)++-- | Manages parsing messages and handling commands for a CommandHandler.+--+-- Returns Right if the command succeeded in parsing and running, Left with the+-- reason otherwise.+handleCommands :: (BotC r, P.Member ParsePrefix r)+               => CommandHandler+               -> Message -- ^ The message that invoked the command+               -> L.Text -- ^ The prefix used+               -> L.Text -- ^ The command string, without a prefix+               -> P.Sem r (Either CmdInvokeFailReason Context)+handleCommands handler msg prefix cmd = P.runError $ do+    (command, unparsedParams) <- P.fromEither $ mapLeft NotFound $ findCommand handler cmd+    ctx <- P.note NoContext =<< buildContext msg prefix command unparsedParams+    P.fromEither . mapLeft (CommandInvokeError ctx) =<< invokeCommand ctx (ctx ^. #command)+    pure ctx+++-- | Run a command DSL, returning the constructed 'CommandHandler'+buildCommands :: forall r a. P.Member (P.Final IO) r+              => P.Sem (DSLState r) a+              -> P.Sem r (CommandHandler, a)+buildCommands m = P.fixpointToFinal $ mdo+  (groups, (cmds, a)) <- inner handler m+  let handler = CommandHandler groups cmds+  pure (handler, a)++  where inner :: CommandHandler -> P.Sem (DSLState r) a+              -> P.Sem (P.Fixpoint ': r) (LH.HashMap S.Text (Group, AliasType),+                                          (LH.HashMap S.Text (Command, AliasType), a))+        inner h =+          P.runReader h .+          P.runReader [] .+          P.runReader defaultHelp . P.untag @"original-help" .+          P.runReader defaultHelp .+          P.runReader False . P.untag @"hidden" .+          P.runReader Nothing .+          runLocalWriter @(LH.HashMap S.Text (Group, AliasType)) .+          runLocalWriter @(LH.HashMap S.Text (Command, AliasType))+        defaultHelp = (const "This command or group has no help.")++-- TODO: turn this into an effect+-- | Attempt to build the context for a command+buildContext :: BotC r => Message -> L.Text -> Command -> L.Text -> P.Sem r (Maybe Context)+buildContext msg prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do+  guild <- join <$> getGuild `traverse` (msg ^. #guildID)+  let member = guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg)+  let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg)+  Just channel <- case gchan of+    Just chan -> pure . pure $ GuildChannel' chan+    Nothing   -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg)+  Just user <- getUser $ getID msg++  pure $ Context msg guild member channel user command prefix unparsed++nextWord :: L.Text -> (L.Text, L.Text)+nextWord = L.break isSpace . L.stripStart++-- | Attempt to find what command was used.+--+-- On error: returns the path of existing groups that were found, so @"group0+-- group1 group2 notacommand"@ will error with @Left ["group0", "group1",+-- "group2"]@+--+-- On success: returns the command that was invoked, and the remaining text+-- after it.+--+-- This function isn't greedy, if you have a group and a command at the same+-- level, this will find the command first and ignore the group.+findCommand :: CommandHandler -> L.Text -> Either [L.Text] (Command, L.Text)+findCommand handler msg = goH $ nextWord msg+  where+    goH :: (L.Text, L.Text) -> Either [L.Text] (Command, L.Text)+    goH ("", _) = Left []+    goH (x, xs) = attachSoFar x+      (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (handler ^. #commands)))+       <> (attachInitial (LH.lookup (L.toStrict x) (handler ^. #groups)) >>= goG (nextWord xs)))++    goG :: (L.Text, L.Text) -> Group -> Either [L.Text] (Command, L.Text)+    goG ("", _) _ = Left []+    goG (x, xs) g = attachSoFar x+      (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (g ^. #commands)))+       <> (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs)))++    attachInitial :: Maybe (a, b) -> Either [L.Text] a+    attachInitial (Just (a, _)) = Right a+    attachInitial Nothing = Left []++    attachSoFar :: L.Text -> Either [L.Text] a -> Either [L.Text] a+    attachSoFar cmd (Left xs) = Left (cmd:xs)+    attachSoFar _ r = r

@@ -0,0 +1,23 @@+-- |+module Calamity.Gateway+    ( module Calamity.Gateway.Shard+    , module Calamity.Gateway.Types+    , module Calamity.Gateway.Intents+    -- * Gateway+    -- $gatewayDocs+    ) where++import           Calamity.Gateway.Shard+import           Calamity.Gateway.Types+import           Calamity.Gateway.Intents++-- $gatewayDocs+--+-- This module contains all the gateway related things.+--+--+-- ==== Registered Metrics+--+--     1. Gauge: @"active_shards"@+--+--         Keeps track of how many shards are currently active.

@@ -0,0 +1,230 @@+-- | module containing all dispatch events+module Calamity.Gateway.DispatchEvents where++import           Calamity.Internal.AesonThings+import           Calamity.Internal.ConstructorName+import           Calamity.Internal.Utils                     ()+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Channel.UpdatedMessage+import           Calamity.Types.Model.Guild.Ban+import           Calamity.Types.Model.Guild.Emoji+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.Guild.Member+import           Calamity.Types.Model.Guild.Role+import           Calamity.Types.Model.Guild.UnavailableGuild+import           Calamity.Types.Model.Presence.Presence+import           Calamity.Types.Model.User+import           Calamity.Types.Model.Voice+import           Calamity.Types.Snowflake+import           Calamity.Types.UnixTimestamp++import           Data.Aeson+import           Data.Dynamic+import           Data.Text.Lazy                              ( Text )+import           Data.Time+import           Data.Typeable+import           Data.Vector.Unboxing                        ( Vector )++import           GHC.Generics++data CalamityEvent+  = Dispatch+    Int -- ^ The shard that pushed this event+    DispatchData -- ^ The attached data+  | Custom+    TypeRep -- ^ The name of the custom event+    Dynamic -- ^ The data sent to the custom event+  | ShutDown+  deriving ( Show, Generic )++data DispatchData+  = Ready !ReadyData+  | Resumed+  | ChannelCreate !Channel+  | ChannelUpdate !Channel+  | ChannelDelete !Channel+  | ChannelPinsUpdate !ChannelPinsUpdateData+  | GuildCreate !Guild+  | GuildUpdate !UpdatedGuild+  | GuildDelete !UnavailableGuild+  | GuildBanAdd !BanData+  | GuildBanRemove !BanData+  | GuildEmojisUpdate !GuildEmojisUpdateData+  | GuildIntegrationsUpdate !GuildIntegrationsUpdateData+  | GuildMemberAdd !Member+  | GuildMemberRemove !GuildMemberRemoveData+  | GuildMemberUpdate !GuildMemberUpdateData+  | GuildMembersChunk !GuildMembersChunkData+  | GuildRoleCreate !GuildRoleData+  | GuildRoleUpdate !GuildRoleData+  | GuildRoleDelete !GuildRoleDeleteData+  | InviteCreate !InviteCreateData+  | InviteDelete !InviteDeleteData+  | MessageCreate !Message !(Maybe User)+  | MessageUpdate !UpdatedMessage+  | MessageDelete !MessageDeleteData+  | MessageDeleteBulk !MessageDeleteBulkData+  | MessageReactionAdd !Reaction+  | MessageReactionRemove !Reaction+  | MessageReactionRemoveAll !MessageReactionRemoveAllData+  | PresenceUpdate !PresenceUpdateData+  | TypingStart !TypingStartData+  | UserUpdate !User+  | VoiceStateUpdate !VoiceState+  | VoiceServerUpdate !VoiceServerUpdateData+  | WebhooksUpdate !WebhooksUpdateData+  deriving ( Show, Generic, CtorName )++data ReadyData = ReadyData+  { v         :: Integer+  , user      :: User+  , guilds    :: [UnavailableGuild]+  , sessionID :: Text+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON ReadyData++data ChannelPinsUpdateData = ChannelPinsUpdateData+  { channelID        :: Snowflake Channel+  , lastPinTimestamp :: Maybe UTCTime+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON ChannelPinsUpdateData++data GuildEmojisUpdateData = GuildEmojisUpdateData+  { guildID :: Snowflake Guild+  , emojis  :: [Emoji]+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildEmojisUpdateData++newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData+  { guildID :: Snowflake Guild+  }+  deriving newtype ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildIntegrationsUpdateData++data GuildMemberRemoveData = GuildMemberRemoveData+  { guildID :: Snowflake Guild+  , user    :: User+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildMemberRemoveData++data GuildMemberUpdateData = GuildMemberUpdateData+  { guildID  :: Snowflake Guild+  , roles    :: Vector (Snowflake Role)+  , user     :: User+  , nick     :: Maybe Text+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildMemberUpdateData++data GuildMembersChunkData = GuildMembersChunkData+  { guildID :: Snowflake Guild+  , members :: [Member]+  }+  deriving ( Show, Generic )++instance FromJSON GuildMembersChunkData where+  parseJSON = withObject "GuildMembersChunkData" $ \v -> do+    guildID <- v .: "guild_id"++    members' <- do+      members' <- v .: "members"+      traverse (\m -> parseJSON $ Object (m <> "guild_id" .= guildID)) members'++    pure $ GuildMembersChunkData guildID members'++data GuildRoleData = GuildRoleData+  { guildID :: Snowflake Guild+  , role    :: Role+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildRoleData++data GuildRoleDeleteData = GuildRoleDeleteData+  { guildID :: Snowflake Guild+  , roleID  :: Snowflake Role+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildRoleDeleteData++data InviteCreateData = InviteCreateData+  { channelID      :: Snowflake Channel+  , code           :: Text+  , createdAt      :: UTCTime+  , guildID        :: Maybe (Snowflake Guild)+  , inviter        :: Maybe (Snowflake User)+  , maxAge         :: Int+  , maxUses        :: Int+  , targetUser     :: Maybe (Snowflake User)+  , targetUserType :: Maybe Integer+  , temporary      :: Bool+  , uses           :: Integer+  }+  deriving ( Show, Generic )+  deriving ( FromJSON ) via WithSpecialCases+      '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"]+      InviteCreateData++data InviteDeleteData = InviteDeleteData+  { channelID :: Snowflake Channel+  , guildID   :: Maybe (Snowflake Guild)+  , code      :: Text+  }+  deriving ( Show, Generic )+  deriving ( FromJSON ) via CalamityJSON InviteDeleteData++data MessageDeleteData = MessageDeleteData+  { id        :: Snowflake Message+  , channelID :: Snowflake Channel+  , guildID   :: Snowflake Guild+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON MessageDeleteData++data MessageDeleteBulkData = MessageDeleteBulkData+  { guildID   :: Snowflake Guild+  , channelID :: Snowflake Channel+  , ids       :: [Snowflake Message]+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON MessageDeleteBulkData++data MessageReactionRemoveAllData = MessageReactionRemoveAllData+  { channelID :: Snowflake Channel+  , messageID :: Snowflake Message+  , guildID   :: Maybe (Snowflake Guild)+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON MessageReactionRemoveAllData++data PresenceUpdateData = PresenceUpdateData+  { userID   :: Snowflake User+  , presence :: Presence+  }+  deriving ( Show, Generic )++instance FromJSON PresenceUpdateData where+  parseJSON = withObject "PresenceUpdate" $ \v -> do+    user <- (v .: "user") >>= (.: "id")+    presence <- parseJSON $ Object v+    pure $ PresenceUpdateData user presence++data TypingStartData = TypingStartData+  { channelID :: Snowflake Channel+  , guildID   :: Maybe (Snowflake Guild)+  , userID    :: Snowflake User+  , timestamp :: UnixTimestamp+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON TypingStartData++newtype VoiceServerUpdateData = VoiceServerUpdateData Value+  deriving newtype ( Show, Generic )+  deriving newtype ( ToJSON, FromJSON )++newtype WebhooksUpdateData = WebhooksUpdateData Value+  deriving newtype ( Show, Generic )+  deriving newtype ( ToJSON, FromJSON )

@@ -0,0 +1,56 @@+{-# LANGUAGE NoDeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Discord gateway intents+module Calamity.Gateway.Intents+    ( Intents(..)+    , defaultIntents+    , intentGuilds+    , intentGuildMembers+    , intentGuildBans+    , intentGuildEmojis+    , intentGuildIntegrations+    , intentGuildWebhooks+    , intentGuildInvites+    , intentGuildVoiceStates+    , intentGuildPresences+    , intentGuildMessages+    , intentGuildMessageReactions+    , intentGuildMessageTyping+    , intentDirectMessages+    , intentDirectMessageReactions+    , intentDirectMessageTyping ) where++import           Data.Aeson    ( ToJSON )+import           Data.Bits+import           Data.Flags    (allBut, (.+.))+import           Data.Flags.TH+import           Data.Word+import           Data.Default.Class++$(bitmaskWrapper "Intents" ''Word32 []+   [ ("intentGuilds", 1 `shiftL` 0)+   , ("intentGuildMembers", 1 `shiftL` 1)+   , ("intentGuildBans", 1 `shiftL` 2)+   , ("intentGuildEmojis", 1 `shiftL` 3)+   , ("intentGuildIntegrations", 1 `shiftL` 4)+   , ("intentGuildWebhooks", 1 `shiftL` 5)+   , ("intentGuildInvites", 1 `shiftL` 6)+   , ("intentGuildVoiceStates", 1 `shiftL` 7)+   , ("intentGuildPresences", 1 `shiftL` 8)+   , ("intentGuildMessages", 1 `shiftL` 9)+   , ("intentGuildMessageReactions", 1 `shiftL` 10)+   , ("intentGuildMessageTyping", 1 `shiftL` 11)+   , ("intentDirectMessages", 1 `shiftL` 12)+   , ("intentDirectMessageReactions", 1 `shiftL` 13)+   , ("intentDirectMessageTyping", 1 `shiftL` 14)])++deriving via Word32 instance ToJSON Intents++-- | Default intents are all but the privileged intents: members and intents+defaultIntents :: Intents+defaultIntents = allBut (intentGuildMembers .+. intentGuildPresences)++-- | Default intents are all but the privileged intents: members and intents+instance Default Intents where+  def = defaultIntents

@@ -0,0 +1,355 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}++-- | The shard logic+module Calamity.Gateway.Shard (+  Shard (..),+  newShard,+) where++import Calamity.Gateway.DispatchEvents+import Calamity.Gateway.Intents+import Calamity.Gateway.Types+import Calamity.Internal.RunIntoIO+import Calamity.Internal.Utils+import Calamity.Metrics.Eff+import Calamity.Types.LogEff+import Calamity.Types.Token+import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Concurrent.Chan.Unagi as UC+import Control.Concurrent.STM+import Control.Concurrent.STM.TBMQueue+import Control.Exception+import qualified Control.Exception.Safe as Ex+import Control.Lens+import Control.Monad+import Control.Monad.State.Lazy+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as LBS+import Data.Default.Class (def)+import Data.Functor+import Data.IORef+import Data.Maybe+import qualified Data.Text.Lazy as L+import DiPolysemy hiding (debug, error, info)+import Fmt+import qualified Network.Connection as NC+import qualified Network.TLS as NT+import qualified Network.TLS.Extra as NT+import Network.WebSockets (+  Connection,+  ConnectionException (..),+  receiveData,+  sendCloseCode,+  sendTextData,+ )+import qualified Network.WebSockets as NW+import qualified Network.WebSockets.Stream as NW+import Polysemy (Sem)+import qualified Polysemy as P+import qualified Polysemy.Async as P+import qualified Polysemy.AtomicState as P+import qualified Polysemy.Error as P+import qualified Polysemy.Resource as P+import qualified System.X509 as X509+import TextShow (showtl)+import Prelude hiding (error)++runWebsocket ::+  P.Members '[LogEff, P.Final IO, P.Embed IO] r =>+  L.Text ->+  L.Text ->+  (Connection -> P.Sem r a) ->+  P.Sem r (Maybe a)+runWebsocket host path ma = do+  inner <- bindSemToIO ma++  -- We have to do this all ourself I think?+  -- TODO: see if this isn't needed+  let logExc e = debug $ "runWebsocket raised with " +|| e ||+ ""+  logExc' <- bindSemToIO logExc+  let handler e = do+        void $ logExc' e+        pure Nothing++  P.embed . Ex.handleAny handler $ do+    ctx <- NC.initConnectionContext+    certStore <- X509.getSystemCertificateStore+    let clientParams =+          (NT.defaultParamsClient (L.unpack host) "443")+            { NT.clientSupported = def{NT.supportedCiphers = NT.ciphersuite_default}+            , NT.clientShared =+                def+                  { NT.sharedCAStore = certStore+                  }+            }+    let tlsSettings = NC.TLSSettings clientParams+        connParams = NC.ConnectionParams (L.unpack host) 443 (Just tlsSettings) Nothing++    Ex.bracket+      (NC.connectTo ctx connParams)+      NC.connectionClose+      ( \conn -> do+          stream <-+            NW.makeStream+              (Just <$> NC.connectionGetChunk conn)+              (maybe (pure ()) (NC.connectionPut conn . LBS.toStrict))+          NW.runClientWithStream stream (L.unpack host) (L.unpack path) NW.defaultConnectionOptions [] inner+      )++newShardState :: Shard -> ShardState+newShardState shard = ShardState shard Nothing Nothing False Nothing Nothing Nothing++-- | Creates and launches a shard+newShard ::+  P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r =>+  L.Text ->+  Int ->+  Int ->+  Token ->+  Maybe StatusUpdateData ->+  Intents ->+  UC.InChan CalamityEvent ->+  Sem r (UC.InChan ControlMessage, Async (Maybe ()))+newShard gateway id count token presence intents evtIn = do+  (cmdIn, cmdOut) <- P.embed UC.newChan+  let shard = Shard id count gateway evtIn cmdOut (rawToken token) presence intents+  stateVar <- P.embed . newIORef $ newShardState shard++  let runShard = P.runAtomicStateIORef stateVar shardLoop+  let action = push "calamity-shard" . attr "shard-id" id $ runShard++  thread' <- P.async action++  pure (cmdIn, thread')++sendToWs :: ShardC r => SentDiscordMessage -> Sem r ()+sendToWs data' = do+  wsConn' <- P.atomicGets wsConn+  case wsConn' of+    Just wsConn -> do+      let encodedData = A.encode data'+      debug $ "sending " +|| data' ||+ " encoded to " +|| encodedData ||+ " to gateway"+      P.embed . sendTextData wsConn $ encodedData+    Nothing -> debug "tried to send to closed WS"++tryWriteTBMQueue' :: TBMQueue a -> a -> STM Bool+tryWriteTBMQueue' q v = do+  v' <- tryWriteTBMQueue q v+  case v' of+    Just False -> retry+    Just True -> pure True+    Nothing -> pure False++restartUnless :: P.Members '[LogEff, P.Error ShardFlowControl] r => L.Text -> Maybe a -> P.Sem r a+restartUnless _ (Just a) = pure a+restartUnless msg Nothing = do+  error msg+  P.throw ShardFlowRestart++-- | The loop a shard will run on+shardLoop :: ShardC r => Sem r ()+shardLoop = do+  activeShards <- registerGauge "active_shards" mempty+  void $ modifyGauge (+ 1) activeShards+  void outerloop+  void $ modifyGauge (subtract 1) activeShards+  debug "Shard shut down"+ where+  controlStream :: Shard -> TBMQueue ShardMsg -> IO ()+  controlStream shard outqueue = inner+   where+    q = shard ^. #cmdOut+    inner = do+      v <- UC.readChan q+      r <- atomically $ tryWriteTBMQueue' outqueue (Control v)+      when r inner++  handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe L.Text) a)+  handleWSException e = pure $ case fromException e of+    Just (CloseRequest code _)+      | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] ->+        Left (ShutDownShard, Just . showtl $ code)+    e -> Left (RestartShard, Just . L.pack . show $ e)++  discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r ()+  discordStream ws outqueue = inner+   where+    inner = do+      msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException++      case msg of+        Left (c, reason) -> do+          whenJust reason (\r -> error $ "Shard closed with reason: " <> r)+          P.embed . atomically $ writeTBMQueue outqueue (Control c)+        Right msg' -> do+          let decoded = A.eitherDecode msg'+          r <- case decoded of+            Right a ->+              P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a)+            Left e -> do+              error $ "Failed to decode: " +| e |+ ""+              pure True+          when r inner+  outerloop :: ShardC r => Sem r ()+  outerloop = whileMFinalIO $ do+    shard :: Shard <- P.atomicGets (^. #shardS)+    let host = shard ^. #gateway+    let host' = fromMaybe host $ L.stripPrefix "wss://" host+    info $ "starting up shard " +| (shard ^. #shardID) |+ " of " +| (shard ^. #shardCount) |+ ""++    innerLoopVal <- runWebsocket host' "/?v=8&encoding=json" innerloop++    case innerLoopVal of+      Just ShardFlowShutDown -> do+        info "Shutting down shard"+        pure False+      Just ShardFlowRestart -> do+        info "Restaring shard"+        pure True+      -- we restart normally when we loop++      Nothing -> do+        -- won't happen unless innerloop starts using a non-deterministic effect or connecting to the ws dies+        info "Restarting shard (abnormal reasons?)"+        pure True++  innerloop :: ShardC r => Connection -> Sem r ShardFlowControl+  innerloop ws = do+    debug "Entering inner loop of shard"++    shard <- P.atomicGets (^. #shardS)+    P.atomicModify' (#wsConn ?~ ws)++    seqNum' <- P.atomicGets (^. #seqNum)+    sessionID' <- P.atomicGets (^. #sessionID)++    case (seqNum', sessionID') of+      (Just n, Just s) -> do+        debug $ "Resuming shard (sessionID: " +| s |+ ", seq: " +| n |+ ")"+        sendToWs+          ( Resume+              ResumeData+                { token = shard ^. #token+                , sessionID = s+                , seq = n+                }+          )+      _noActiveSession -> do+        debug "Identifying shard"+        sendToWs+          ( Identify+              IdentifyData+                { token = shard ^. #token+                , properties =+                    IdentifyProps+                      { browser = "Calamity: https://github.com/simmsb/calamity"+                      , device = "Calamity: https://github.com/simmsb/calamity"+                      }+                , compress = False+                , largeThreshold = 250+                , shard =+                    ( shard ^. #shardID+                    , shard ^. #shardCount+                    )+                , presence = shard ^. #initialStatus+                , intents = shard ^. #intents+                }+          )++    result <-+      P.resourceToIOFinal $+        P.bracket+          (P.embed $ newTBMQueueIO 1)+          (P.embed . atomically . closeTBMQueue)+          ( \q -> do+              debug "handling events now"+              _controlThread <- P.async . P.embed $ controlStream shard q+              _discordThread <- P.async $ discordStream ws q+              P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do+                -- only we close the queue+                msg <- P.embed . atomically $ readTBMQueue q+                handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg+          )++    debug "Exiting inner loop of shard"++    P.atomicModify' (#wsConn .~ Nothing)+    haltHeartBeat+    pure result+  handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r ()+  handleMsg (Discord msg) = case msg of+    EvtDispatch sn data' -> do+      -- trace $ "Handling event: ("+||data'||+")"+      P.atomicModify' (#seqNum ?~ sn)++      case data' of+        Ready rdata' ->+          P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID))+        _NotReady -> pure ()++      shard <- P.atomicGets (^. #shardS)+      P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data')+    HeartBeatReq -> do+      debug "Received heartbeat request"+      sendHeartBeat+    Reconnect -> do+      debug "Being asked to restart by Discord"+      P.throw ShardFlowRestart+    InvalidSession resumable -> do+      if resumable+        then info "Received resumable invalid session"+        else do+          info "Received non-resumable invalid session, sleeping for 15 seconds then retrying"+          P.atomicModify' (#sessionID .~ Nothing)+          P.atomicModify' (#seqNum .~ Nothing)+          P.embed $ threadDelay (15 * 1000 * 1000)+      P.throw ShardFlowRestart+    Hello interval -> do+      info $ "Received hello, beginning to heartbeat at an interval of " +| interval |+ "ms"+      startHeartBeatLoop interval+    HeartBeatAck -> do+      debug "Received heartbeat ack"+      P.atomicModify' (#hbResponse .~ True)+  handleMsg (Control msg) = case msg of+    SendPresence data' -> do+      debug $ "Sending presence: (" +|| data' ||+ ")"+      sendToWs $ StatusUpdate data'+    RestartShard -> P.throw ShardFlowRestart+    ShutDownShard -> P.throw ShardFlowShutDown++startHeartBeatLoop :: ShardC r => Int -> Sem r ()+startHeartBeatLoop interval = do+  haltHeartBeat -- cancel any currently running hb thread+  thread <- P.async $ heartBeatLoop interval+  P.atomicModify' (#hbThread ?~ thread)++haltHeartBeat :: ShardC r => Sem r ()+haltHeartBeat = do+  thread <- P.atomicState @ShardState . (swap .) . runState $ do+    thread <- use #hbThread+    #hbThread .= Nothing+    pure thread+  case thread of+    Just t -> do+      debug "Stopping heartbeat thread"+      P.embed (void $ cancel t)+    Nothing -> pure ()++sendHeartBeat :: ShardC r => Sem r ()+sendHeartBeat = do+  sn <- P.atomicGets (^. #seqNum)+  debug $ "Sending heartbeat (seq: " +|| sn ||+ ")"+  sendToWs $ HeartBeat sn+  P.atomicModify' (#hbResponse .~ False)++heartBeatLoop :: ShardC r => Int -> Sem r ()+heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do+  sendHeartBeat+  P.embed . threadDelay $ interval * 1000+  unlessM (P.atomicGets (^. #hbResponse)) $ do+    debug "No heartbeat response, restarting shard"+    wsConn <- P.note () =<< P.atomicGets (^. #wsConn)+    P.embed $ sendCloseCode wsConn 4000 ("No heartbeat in time" :: L.Text)+    P.throw ()

@@ -0,0 +1,289 @@+-- | Types for shards+module Calamity.Gateway.Types+    ( ShardC+    , ShardMsg(..)+    , ReceivedDiscordMessage(..)+    , SentDiscordMessage(..)+    , DispatchType(..)+    , IdentifyData(..)+    , StatusUpdateData(..)+    , ResumeData(..)+    , RequestGuildMembersData(..)+    , IdentifyProps(..)+    , ControlMessage(..)+    , ShardFlowControl(..)+    , Shard(..)+    , ShardState(..) ) where++import           Calamity.Gateway.DispatchEvents+import           Calamity.Gateway.Intents+import           Calamity.Internal.AesonThings+import           Calamity.Metrics.Eff+import           Calamity.Types.LogEff+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.Voice+import           Calamity.Types.Model.Presence.Activity+import           Calamity.Types.Snowflake++import           Control.Concurrent.Async+import           Control.Concurrent.Chan.Unagi++import           Data.Aeson+import qualified Data.Aeson.Types                 as AT+import           Data.Generics.Labels             ()+import           Data.Maybe+import           Data.Text.Lazy                   ( Text )++import           GHC.Generics++import           Network.WebSockets.Connection    ( Connection )++import qualified Polysemy                         as P+import qualified Polysemy.Async                   as P+import qualified Polysemy.AtomicState             as P+import qualified TextShow.Generic as TSG+import TextShow (TextShow)+import Control.Lens.Operators ((^?))+import Data.Aeson.Types (parseMaybe)+import Control.Lens (Ixed(ix))+import Data.Aeson.Lens++type ShardC r = (P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO,+  P.Async, MetricEff] r)++data ShardMsg+  = Discord ReceivedDiscordMessage+  | Control ControlMessage+  deriving ( Show, Generic )++data ReceivedDiscordMessage+  = EvtDispatch Int !DispatchData+  | HeartBeatReq+  | Reconnect+  | InvalidSession Bool+  | Hello Int+  | HeartBeatAck+  deriving ( Show, Generic )++instance FromJSON ReceivedDiscordMessage where+  parseJSON = withObject "ReceivedDiscordMessage" $ \v -> do+    op :: Int <- v .: "op"+    case op of+      0  -> do+        d <- v .: "d"+        t <- v .: "t"+        s <- v .: "s"+        EvtDispatch s <$> parseDispatchData t d++      1  -> pure HeartBeatReq++      7  -> pure Reconnect++      9  -> InvalidSession <$> v .: "d"++      10 -> Hello <$> do+        d <- v .: "d"+        d .: "heartbeat_interval"++      11 -> pure HeartBeatAck++      _  -> fail $ "invalid opcode: " <> show op++parseDispatchData :: DispatchType -> Value -> AT.Parser DispatchData+parseDispatchData READY data'                       = Ready <$> parseJSON data'+parseDispatchData RESUMED _                         = pure Resumed+parseDispatchData CHANNEL_CREATE data'              = ChannelCreate <$> parseJSON data'+parseDispatchData CHANNEL_UPDATE data'              = ChannelUpdate <$> parseJSON data'+parseDispatchData CHANNEL_DELETE data'              = ChannelDelete <$> parseJSON data'+parseDispatchData CHANNEL_PINS_UPDATE data'         = ChannelPinsUpdate <$> parseJSON data'+parseDispatchData GUILD_CREATE data'                = GuildCreate <$> parseJSON data'+parseDispatchData GUILD_UPDATE data'                = GuildUpdate <$> parseJSON data'+parseDispatchData GUILD_DELETE data'                = GuildDelete <$> parseJSON data'+parseDispatchData GUILD_BAN_ADD data'               = GuildBanAdd <$> parseJSON data'+parseDispatchData GUILD_BAN_REMOVE data'            = GuildBanRemove <$> parseJSON data'+parseDispatchData GUILD_EMOJIS_UPDATE data'         = GuildEmojisUpdate <$> parseJSON data'+parseDispatchData GUILD_INTEGRATIONS_UPDATE data'   = GuildIntegrationsUpdate <$> parseJSON data'+parseDispatchData GUILD_MEMBER_ADD data'            = GuildMemberAdd <$> parseJSON data'+parseDispatchData GUILD_MEMBER_REMOVE data'         = GuildMemberRemove <$> parseJSON data'+parseDispatchData GUILD_MEMBER_UPDATE data'         = GuildMemberUpdate <$> parseJSON data'+parseDispatchData GUILD_MEMBERS_CHUNK data'         = GuildMembersChunk <$> parseJSON data'+parseDispatchData GUILD_ROLE_CREATE data'           = GuildRoleCreate <$> parseJSON data'+parseDispatchData GUILD_ROLE_UPDATE data'           = GuildRoleUpdate <$> parseJSON data'+parseDispatchData GUILD_ROLE_DELETE data'           = GuildRoleDelete <$> parseJSON data'+parseDispatchData INVITE_CREATE data'               = InviteCreate <$> parseJSON data'+parseDispatchData INVITE_DELETE data'               = InviteDelete <$> parseJSON data'+parseDispatchData MESSAGE_CREATE data'              = do+  message <- parseJSON data'+  let user = parseMaybe parseJSON =<< (data' ^? _Object . ix "author")+  pure $ MessageCreate message user+parseDispatchData MESSAGE_UPDATE data'              = MessageUpdate <$> parseJSON data'+parseDispatchData MESSAGE_DELETE data'              = MessageDelete <$> parseJSON data'+parseDispatchData MESSAGE_DELETE_BULK data'         = MessageDeleteBulk <$> parseJSON data'+parseDispatchData MESSAGE_REACTION_ADD data'        = MessageReactionAdd <$> parseJSON data'+parseDispatchData MESSAGE_REACTION_REMOVE data'     = MessageReactionRemove <$> parseJSON data'+parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> parseJSON data'+parseDispatchData PRESENCE_UPDATE data'             = PresenceUpdate <$> parseJSON data'+parseDispatchData TYPING_START data'                = TypingStart <$> parseJSON data'+parseDispatchData USER_UPDATE data'                 = UserUpdate <$> parseJSON data'+parseDispatchData VOICE_STATE_UPDATE data'          = VoiceStateUpdate <$> parseJSON data'+parseDispatchData VOICE_SERVER_UPDATE data'         = VoiceServerUpdate <$> parseJSON data'+parseDispatchData WEBHOOKS_UPDATE data'             = WebhooksUpdate <$> parseJSON data'++data SentDiscordMessage+  = StatusUpdate StatusUpdateData+  | Identify IdentifyData+  | HeartBeat (Maybe Int)+  | VoiceStatusUpdate VoiceState+  | Resume ResumeData+  | RequestGuildMembers RequestGuildMembersData+  deriving ( Show, Generic )++instance ToJSON SentDiscordMessage where+  toJSON (HeartBeat data') = object ["op" .= (1 :: Int), "d" .= data']++  toJSON (Identify data') = object ["op" .= (2 :: Int), "d" .= data']++  toJSON (StatusUpdate data') = object ["op" .= (3 :: Int), "d" .= data']++  toJSON (VoiceStatusUpdate data') = object ["op" .= (4 :: Int), "d" .= data']++  toJSON (Resume data') = object ["op" .= (6 :: Int), "d" .= data']++  toJSON (RequestGuildMembers data') = object ["op" .= (8 :: Int), "d" .= data']++  toEncoding (HeartBeat data') = pairs ("op" .= (1 :: Int) <> "d" .= data')++  toEncoding (Identify data') = pairs ("op" .= (2 :: Int) <> "d" .= data')++  toEncoding (StatusUpdate data') = pairs ("op" .= (3 :: Int) <> "d" .= data')++  toEncoding (VoiceStatusUpdate data') = pairs ("op" .= (4 :: Int) <> "d" .= data')++  toEncoding (Resume data') = pairs ("op" .= (6 :: Int) <> "d" .= data')++  toEncoding (RequestGuildMembers data') = pairs ("op" .= (8 :: Int) <> "d" .= data')++-- Thanks sbrg:+-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs+data DispatchType+  = READY+  | RESUMED+  | CHANNEL_CREATE+  | CHANNEL_UPDATE+  | CHANNEL_DELETE+  | CHANNEL_PINS_UPDATE+  | GUILD_CREATE+  | GUILD_UPDATE+  | GUILD_DELETE+  | GUILD_BAN_ADD+  | GUILD_BAN_REMOVE+  | GUILD_EMOJIS_UPDATE+  | GUILD_INTEGRATIONS_UPDATE+  | GUILD_MEMBER_ADD+  | GUILD_MEMBER_REMOVE+  | GUILD_MEMBER_UPDATE+  | GUILD_MEMBERS_CHUNK+  | GUILD_ROLE_CREATE+  | GUILD_ROLE_UPDATE+  | GUILD_ROLE_DELETE+  | INVITE_CREATE+  | INVITE_DELETE+  | MESSAGE_CREATE+  | MESSAGE_UPDATE+  | MESSAGE_DELETE+  | MESSAGE_DELETE_BULK+  | MESSAGE_REACTION_ADD+  | MESSAGE_REACTION_REMOVE+  | MESSAGE_REACTION_REMOVE_ALL+  | PRESENCE_UPDATE+  | TYPING_START+  | USER_UPDATE+  | VOICE_STATE_UPDATE+  | VOICE_SERVER_UPDATE+  | WEBHOOKS_UPDATE+  deriving ( Show, Eq, Enum, Generic )+  deriving anyclass ( ToJSON, FromJSON )++data IdentifyData = IdentifyData+  { token          :: Text+  , properties     :: IdentifyProps+  , compress       :: Bool+  , largeThreshold :: Int+  , shard          :: (Int, Int)+  , presence       :: Maybe StatusUpdateData+  , intents        :: Intents+  }+  deriving ( Show, Generic )+  deriving ToJSON via CalamityJSON IdentifyData++data StatusUpdateData = StatusUpdateData+  { since  :: Maybe Integer+  , game   :: Maybe Activity+  , status :: Text+  , afk    :: Bool+  }+  deriving ( Show, Generic )+  deriving ToJSON via CalamityJSONKeepNothing StatusUpdateData++data ResumeData = ResumeData+  { token     :: Text+  , sessionID :: Text+  , seq       :: Int+  }+  deriving ( Show, Generic )+  deriving ( ToJSON, FromJSON ) via CalamityJSON ResumeData++data RequestGuildMembersData = RequestGuildMembersData+  { guildID :: Snowflake Guild+  , query   :: Maybe Text+  , limit   :: Maybe Int+  }+  deriving ( Show, Generic )++instance ToJSON RequestGuildMembersData where+  toJSON RequestGuildMembersData { guildID, query, limit } =+    object ["guild_id" .= guildID, "query" .= fromMaybe "" query, "limit" .= fromMaybe 0 limit]++data IdentifyProps = IdentifyProps+  { browser :: Text+  , device  :: Text+  }+  deriving ( Show, Generic )++instance ToJSON IdentifyProps where+  toJSON IdentifyProps { browser, device } = object ["$browser" .= browser, "$device" .= device]++data ControlMessage+  = RestartShard+  | ShutDownShard+  | SendPresence StatusUpdateData+  deriving ( Show, Generic )++data ShardFlowControl+  = ShardFlowRestart+  | ShardFlowShutDown+  deriving ( Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric ShardFlowControl++data Shard = Shard+  { shardID       :: Int+  , shardCount    :: Int+  , gateway       :: Text+  , evtIn         :: InChan CalamityEvent+  , cmdOut        :: OutChan ControlMessage+  , token         :: Text+  , initialStatus :: Maybe StatusUpdateData+  , intents       :: Intents+  }+  deriving ( Generic )++data ShardState = ShardState+  { shardS     :: Shard+  , seqNum     :: Maybe Int+  , hbThread   :: Maybe (Async (Maybe ()))+  , hbResponse :: Bool+  , wsHost     :: Maybe Text+  , sessionID  :: Maybe Text+  , wsConn     :: Maybe Connection+  }+  deriving ( Generic )

@@ -0,0 +1,54 @@+-- | Combined http request stuff+module Calamity.HTTP+    ( invoke+    , module Calamity.HTTP.AuditLog+    , module Calamity.HTTP.Channel+    , module Calamity.HTTP.Emoji+    , module Calamity.HTTP.Guild+    , module Calamity.HTTP.Invite+    , module Calamity.HTTP.MiscRoutes+    , module Calamity.HTTP.User+    , module Calamity.HTTP.Reason+    , module Calamity.HTTP.Internal.Types+    , module Calamity.HTTP.Webhook+    -- * HTTP+    -- $httpDocs+    ) where++import           Calamity.HTTP.AuditLog+import           Calamity.HTTP.Channel+import           Calamity.HTTP.Emoji+import           Calamity.HTTP.Guild+import           Calamity.HTTP.Internal.Request ( invoke )+import           Calamity.HTTP.Internal.Types   ( RestError )+import           Calamity.HTTP.Invite+import           Calamity.HTTP.MiscRoutes+import           Calamity.HTTP.Reason+import           Calamity.HTTP.User+import           Calamity.HTTP.Webhook++-- $httpDocs+--+-- This module contains all the http related things+--+--+-- ==== Registered Metrics+--+--     1. Gauge: @"inflight_requests" [route]@+--+--         Keeps track of how many requests are currently in-flight, the @route@+--         parameter will be the route that is currently active.+--+--     2. Counter: @"total_requests" [route]@+--+--         Incremented on every request, the @route@ parameter is the route that+--         the request was made on.+--+--+-- ==== Examples+--+-- Editing a message:+--+-- @+-- 'invoke' $ 'EditMessage' someChannel someMessage ('Just' "new content") 'Nothing'+-- @

@@ -0,0 +1,47 @@+-- | Audit Log endpoints+module Calamity.HTTP.AuditLog (+  AuditLogRequest (..),+  GetAuditLogOptions (..),+) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.Utils ()+import Calamity.Types.Model.Guild+import Calamity.Types.Model.User+import Calamity.Types.Snowflake++import Control.Lens++import Data.Default.Class++import GHC.Generics++import TextShow (showt)++data GetAuditLogOptions = GetAuditLogOptions+  { userID :: Maybe (Snowflake User)+  , actionType :: Maybe AuditLogAction+  , before :: Maybe (Snowflake AuditLogEntry)+  , limit :: Maybe Integer+  }+  deriving (Show, Generic, Default)++data AuditLogRequest a where+  GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog++instance Request (AuditLogRequest a) where+  type Result (AuditLogRequest a) = a++  route (GetAuditLog (getID @Guild -> gid) _) =+    mkRouteBuilder // S "guilds" // ID @Guild // S "audit-logs"+      & giveID gid+      & buildRoute++  action (GetAuditLog _ GetAuditLogOptions{userID, actionType, before, limit}) =+    getWithP+      ( "user_id" =:? (showt <$> userID)+          <> "action_type" =:? (showt . fromEnum <$> actionType)+          <> "before" =:? (showt <$> before)+          <> "limit" =:? (showt <$> limit)+      )

@@ -0,0 +1,333 @@+-- | Channel endpoints+module Calamity.HTTP.Channel (+    ChannelRequest (..),+    CreateMessageOptions (..),+    EditMessageData (..),+    editMessageContent,+    editMessageEmbed,+    editMessageFlags,+    editMessageAllowedMentions,+    ChannelUpdate (..),+    AllowedMentionType (..),+    AllowedMentions (..),+    ChannelMessagesFilter (..),+    ChannelMessagesLimit (..),+    GetReactionsOptions (..),+    CreateChannelInviteOptions (..),+    GroupDMAddRecipientOptions (..),+) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.AesonThings+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.User+import Calamity.Types.Snowflake+import Control.Lens hiding ((.=))+import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.Default.Class+import Data.Generics.Product.Subtype (upcast)+import qualified Data.HashMap.Strict as H+import Data.Text (Text)+import qualified Data.Text as S+import Data.Word+import GHC.Generics+import Network.HTTP.Client.MultipartFormData+import Network.HTTP.Req+import Network.Mime+import TextShow++data CreateMessageOptions = CreateMessageOptions+  { content :: Maybe Text+  , nonce :: Maybe Text+  , tts :: Maybe Bool+  , file :: Maybe (Text, ByteString)+  , embed :: Maybe Embed+  , allowedMentions :: Maybe AllowedMentions+  }+  deriving (Show, Generic, Default)++data AllowedMentionType+  = AllowedMentionRoles+  | AllowedMentionUsers+  | AllowedMentionEveryone+  deriving (Show, Generic)++instance ToJSON AllowedMentionType where+  toJSON AllowedMentionRoles = String "roles"+  toJSON AllowedMentionUsers = String "users"+  toJSON AllowedMentionEveryone = String "everyone"++data AllowedMentions = AllowedMentions+  { parse :: [AllowedMentionType]+  , roles :: [Snowflake Role]+  , users :: [Snowflake User]+  }+  deriving (Show, Generic, Default)+  deriving (ToJSON) via CalamityJSON AllowedMentions++instance Semigroup AllowedMentions where+  AllowedMentions p0 r0 u0 <> AllowedMentions p1 r1 u1 =+    AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1)++instance Monoid AllowedMentions where+  mempty = def++data CreateMessageJson = CreateMessageJson+  { content :: Maybe Text+  , nonce :: Maybe Text+  , tts :: Maybe Bool+  , embed :: Maybe Embed+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateMessageJson++-- | Parameters to the Edit Message endpoint.+--+-- Use the provided methods (@editMessageX@) to create a value with the+-- field set, use the Semigroup instance to union the values.+--+-- ==== Examples+--+-- >>> encode $ editMessageContent (Just "test") <> editMessageFlags Nothing+-- "{\"nick\":\"test\",\"deaf\":null}"+newtype EditMessageData = EditMessageData Object+    deriving (Show, Generic)+    deriving newtype (ToJSON, Semigroup, Monoid)++editMessageContent :: Maybe Text -> EditMessageData+editMessageContent v = EditMessageData $ H.fromList [("content", toJSON v)]++editMessageEmbed :: Maybe Embed -> EditMessageData+editMessageEmbed v = EditMessageData $ H.fromList [("embed", toJSON v)]++editMessageFlags :: Maybe Word64 -> EditMessageData+editMessageFlags v = EditMessageData $ H.fromList [("flags", toJSON v)]++editMessageAllowedMentions :: Maybe AllowedMentions -> EditMessageData+editMessageAllowedMentions v = EditMessageData $ H.fromList [("allowed_mentions", toJSON v)]++data ChannelUpdate = ChannelUpdate+  { name :: Maybe Text+  , position :: Maybe Int+  , topic :: Maybe Text+  , nsfw :: Maybe Bool+  , rateLimitPerUser :: Maybe Int+  , bitrate :: Maybe Int+  , userLimit :: Maybe Int+  , permissionOverwrites :: Maybe [Overwrite]+  , parentID :: Maybe (Snowflake Channel)+  }+  deriving (Generic, Show, Default)+  deriving (ToJSON) via CalamityJSON ChannelUpdate++data ChannelMessagesFilter+  = ChannelMessagesAround+      { around :: Snowflake Message+      }+  | ChannelMessagesBefore+      { before :: Snowflake Message+      }+  | ChannelMessagesAfter+      { after :: Snowflake Message+      }+  deriving (Generic, Show)+  deriving (ToJSON) via CalamityJSON ChannelMessagesFilter++newtype ChannelMessagesLimit = ChannelMessagesLimit+  { limit :: Integer+  }+  deriving (Generic, Show)++data GetReactionsOptions = GetReactionsOptions+  { before :: Maybe (Snowflake User)+  , after :: Maybe (Snowflake User)+  , limit :: Maybe Integer+  }+  deriving (Show, Generic, Default)++data CreateChannelInviteOptions = CreateChannelInviteOptions+  { maxAge :: Maybe Int+  , maxUses :: Maybe Int+  , temporary :: Maybe Bool+  , unique :: Maybe Bool+  }+  deriving (Show, Generic, Default)+  deriving (ToJSON) via CalamityJSON CreateChannelInviteOptions++data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions+  { accessToken :: Text+  , nick :: Text+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON GroupDMAddRecipientOptions++data ChannelRequest a where+  CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message+  GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message+  EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> EditMessageData -> ChannelRequest Message+  DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  BulkDeleteMessages :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest ()+  GetChannel :: (HasID Channel c) => c -> ChannelRequest Channel+  ModifyChannel :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel+  DeleteChannel :: (HasID Channel c) => c -> ChannelRequest ()+  GetChannelMessages :: (HasID Channel c) => c -> Maybe ChannelMessagesFilter -> Maybe ChannelMessagesLimit -> ChannelRequest [Message]+  CreateReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest ()+  DeleteOwnReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest ()+  DeleteUserReaction :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest ()+  GetReactions :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User]+  DeleteAllReactions :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  GetChannelInvites :: (HasID Channel c) => c -> ChannelRequest [Invite]+  CreateChannelInvite :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite+  EditChannelPermissions :: (HasID Channel c) => c -> Overwrite -> ChannelRequest ()+  DeleteChannelPermission :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest ()+  TriggerTyping :: (HasID Channel c) => c -> ChannelRequest ()+  GetPinnedMessages :: (HasID Channel c) => c -> ChannelRequest [Message]+  AddPinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  DeletePinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  GroupDMAddRecipient :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest ()+  GroupDMRemoveRecipient :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest ()++baseRoute :: Snowflake Channel -> RouteBuilder _+baseRoute id =+  mkRouteBuilder // S "channels" // ID @Channel+    & giveID id++instance Request (ChannelRequest a) where+  type Result (ChannelRequest a) = a++  route (CreateMessage (getID -> id) _) =+    baseRoute id // S "messages"+      & buildRoute+  route (GetChannel (getID -> id)) =+    baseRoute id+      & buildRoute+  route (ModifyChannel (getID -> id) _) =+    baseRoute id+      & buildRoute+  route (DeleteChannel (getID -> id)) =+    baseRoute id+      & buildRoute+  route (GetChannelMessages (getID -> id) _ _) =+    baseRoute id // S "messages"+      & buildRoute+  route (GetMessage (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "messages" // ID @Message+      & giveID mid+      & buildRoute+  route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me"+      & giveID mid+      & buildRoute+  route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me"+      & giveID mid+      & buildRoute+  route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // ID @User+      & giveID mid+      & giveID uid+      & buildRoute+  route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji)+      & giveID mid+      & buildRoute+  route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "messages" // ID @Message // S "reactions"+      & giveID mid+      & buildRoute+  route (EditMessage (getID -> cid) (getID @Message -> mid) _) =+    baseRoute cid // S "messages" // ID @Message+      & giveID mid+      & buildRoute+  route (DeleteMessage (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "messages" // ID @Message+      & giveID mid+      & buildRoute+  route (BulkDeleteMessages (getID -> cid) _) =+    baseRoute cid // S "messages" // S "bulk-delete"+      & buildRoute+  route (GetChannelInvites (getID -> cid)) =+    baseRoute cid // S "invites"+      & buildRoute+  route (CreateChannelInvite (getID -> cid) _) =+    baseRoute cid // S "invites"+      & buildRoute+  route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) =+    baseRoute cid // S "permissions" // ID @Overwrite+      & giveID oid+      & buildRoute+  route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) =+    baseRoute cid // S "permissions" // ID @Overwrite+      & giveID oid+      & buildRoute+  route (TriggerTyping (getID -> cid)) =+    baseRoute cid // S "typing"+      & buildRoute+  route (GetPinnedMessages (getID -> cid)) =+    baseRoute cid // S "pins"+      & buildRoute+  route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "pins" // ID @Message+      & giveID mid+      & buildRoute+  route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "pins" // ID @Message+      & giveID mid+      & buildRoute+  route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) =+    baseRoute cid // S "recipients" // ID @User+      & giveID uid+      & buildRoute+  route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) =+    baseRoute cid // S "recipients" // ID @User+      & giveID uid+      & buildRoute++  action (CreateMessage _ o@CreateMessageOptions{file = Nothing}) =+    postWith'+      (ReqBodyJson . upcast @CreateMessageJson $ o)+  action (CreateMessage _ cm@CreateMessageOptions{file = Just f}) = \u o -> do+    let filePart =+          (partLBS @IO "file" (snd f))+            { partFilename = Just (S.unpack $ fst f)+            , partContentType = Just (defaultMimeLookup $ fst f)+            }+    body <- reqBodyMultipart [filePart, partLBS "payload_json" (encode . upcast @CreateMessageJson $ cm)]+    postWith' body u o+  action (GetChannel _) = getWith+  action (ModifyChannel _ p) = putWith' (ReqBodyJson p)+  action (DeleteChannel _) = deleteWith+  action (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a))) l) =+    getWithP ("around" =: a <> "limit" =:? (showt . (^. #limit) <$> l))+  action (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a))) l) =+    getWithP ("before" =: a <> "limit" =:? (showt . (^. #limit) <$> l))+  action (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a))) l) =+    getWithP ("after" =: a <> "limit" =:? (showt . (^. #limit) <$> l))+  action (GetChannelMessages _ Nothing _) = getWith+  action (GetMessage _ _) = getWith+  action CreateReaction{} = putEmpty+  action DeleteOwnReaction{} = deleteWith+  action DeleteUserReaction{} = deleteWith+  action (GetReactions _ _ _ GetReactionsOptions{before, after, limit}) =+    getWithP+      ( "before" =:? (showt <$> before)+          <> "after" =:? (showt <$> after)+          <> "limit" =:? (showt <$> limit)+      )+  action (DeleteAllReactions _ _) = deleteWith+  action (EditMessage _ _ o) = patchWith' (ReqBodyJson o)+  action (DeleteMessage _ _) = deleteWith+  action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ object ["messages" .= ids])+  action (GetChannelInvites _) = getWith+  action (CreateChannelInvite _ o) = postWith' (ReqBodyJson o)+  action (EditChannelPermissions _ o) = putWith' (ReqBodyJson o)+  action (DeleteChannelPermission _ _) = deleteWith+  action (TriggerTyping _) = postEmpty+  action (GetPinnedMessages _) = getWith+  action (AddPinnedMessage _ _) = putEmpty+  action (DeletePinnedMessage _ _) = deleteWith+  action (GroupDMAddRecipient _ _ o) = putWith' (ReqBodyJson o)+  action (GroupDMRemoveRecipient _ _) = deleteWith

@@ -0,0 +1,70 @@+-- | Emoji endpoints+module Calamity.HTTP.Emoji (+  EmojiRequest (..),+  CreateGuildEmojiOptions (..),+  ModifyGuildEmojiOptions (..),+) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.AesonThings+import Calamity.Internal.Utils ()+import Calamity.Types.Model.Guild+import Calamity.Types.Snowflake++import Data.Aeson+import Data.Function+import Data.Text (Text)++import GHC.Generics++import Network.HTTP.Req++data CreateGuildEmojiOptions = CreateGuildEmojiOptions+  { name :: Text+  , image :: Text+  , roles :: [Snowflake Role]+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateGuildEmojiOptions++data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions+  { name :: Text+  , roles :: [Snowflake Role]+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON ModifyGuildEmojiOptions++data EmojiRequest a where+  ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji]+  GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji+  CreateGuildEmoji :: (HasID Guild g) => g -> CreateGuildEmojiOptions -> EmojiRequest Emoji+  ModifyGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> ModifyGuildEmojiOptions -> EmojiRequest Emoji+  DeleteGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest ()++baseRoute :: Snowflake Guild -> RouteBuilder _+baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild // S "emojis" & giveID id++instance Request (EmojiRequest a) where+  type Result (EmojiRequest a) = a++  route (ListGuildEmojis (getID -> gid)) = baseRoute gid & buildRoute+  route (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) =+    baseRoute gid // ID @Emoji+      & giveID eid+      & buildRoute+  route (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute+  route (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) =+    baseRoute gid // ID @Emoji+      & giveID eid+      & buildRoute+  route (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) =+    baseRoute gid // ID @Emoji+      & giveID eid+      & buildRoute++  action (ListGuildEmojis _) = getWith+  action (GetGuildEmoji _ _) = getWith+  action (CreateGuildEmoji _ o) = postWith' (ReqBodyJson o)+  action (ModifyGuildEmoji _ _ o) = patchWith' (ReqBodyJson o)+  action (DeleteGuildEmoji _ _) = deleteWith

@@ -0,0 +1,358 @@+-- | Guild endpoints+module Calamity.HTTP.Guild (+    GuildRequest (..),+    CreateGuildData (..),+    ModifyGuildData (..),+    ChannelCreateData (..),+    ChannelPosition (..),+    ListMembersOptions (..),+    AddGuildMemberData (..),+    ModifyGuildMemberData (..),+    modifyGuildMemberNick,+    modifyGuildMemberRoles,+    modifyGuildMemberMute,+    modifyGuildMemberDeaf,+    modifyGuildMemberChannelID,+    CreateGuildBanData (..),+    ModifyGuildRoleData (..),+    modifyGuildRoleName,+    modifyGuildRolePermissions,+    modifyGuildRoleColour,+    modifyGuildRoleHoist,+    modifyGuildRoleMentionable,+    ModifyGuildRolePositionsData (..),+) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.AesonThings+import Calamity.Internal.IntColour ()+import Calamity.Internal.Utils ()+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.User+import Calamity.Types.Model.Voice+import Calamity.Types.Snowflake+import Control.Lens hiding ((.=))+import Data.Aeson+import Data.Aeson.Lens+import Data.Colour (Colour)+import Data.Default.Class+import qualified Data.HashMap.Strict as H+import Data.Text (Text)+import GHC.Generics+import Network.HTTP.Req+import TextShow++data CreateGuildData = CreateGuildData+  { name :: Text+  , region :: Text+  , icon :: Text+  , verificationLevel :: Integer -- TODO: enums for these+  , defaultMessageNotifications :: Integer+  , explicitContentFilter :: Integer+  , roles :: [Role]+  , channels :: [Partial Channel]+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON CreateGuildData++data ModifyGuildData = ModifyGuildData+  { name :: Maybe Text+  , region :: Maybe Text+  , icon :: Maybe Text+  , verificationLevel :: Maybe Integer -- TODO: enums for these+  , defaultMessageNotifications :: Maybe Integer+  , explicitContentFilter :: Maybe Integer+  , afkChannelID :: Maybe (Snowflake GuildChannel)+  , afkTimeout :: Maybe Integer+  , ownerID :: Maybe (Snowflake User)+  , splash :: Maybe Text+  , banner :: Maybe Text+  , systemChannelID :: Maybe (Snowflake GuildChannel)+  }+  deriving (Show, Generic, Default)+  deriving (ToJSON) via CalamityJSON ModifyGuildData++data ChannelCreateData = ChannelCreateData+  { name :: Text+  , type_ :: Maybe ChannelType+  , topic :: Maybe Text+  , bitrate :: Maybe Integer+  , userLimit :: Maybe Integer+  , rateLimitPerUser :: Maybe Integer+  , position :: Maybe Integer+  , permissionOverwrites :: Maybe [Overwrite]+  , parentID :: Maybe (Snowflake Category)+  , nsfw :: Maybe Bool+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON ChannelCreateData++data ChannelPosition = ChannelPosition+  { id :: Snowflake GuildChannel+  , position :: Maybe Integer+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON ChannelPosition++data ListMembersOptions = ListMembersOptions+  { limit :: Maybe Integer+  , after :: Maybe (Snowflake User)+  }+  deriving (Show, Generic, Default)++data AddGuildMemberData = AddGuildMemberData+  { accessToken :: Text+  , nick :: Maybe Text+  , roles :: Maybe [Snowflake Role]+  , mute :: Maybe Bool+  , deaf :: Maybe Bool+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON AddGuildMemberData++-- | Parameters to the Modify Guild Member endpoint.+--+-- Use the provided methods (@modifyGuildMemberX@) to create a value with the+-- field set, use the Semigroup instance to union the values.+--+-- ==== Examples+--+-- >>> encode $ modifyGuildMemberNick (Just "test") <> modifyGuildMemberDeaf Nothing+-- "{\"nick\":\"test\",\"deaf\":null}"+newtype ModifyGuildMemberData = ModifyGuildMemberData Object+    deriving (Show, Generic)+    deriving newtype (ToJSON, Semigroup, Monoid)++modifyGuildMemberNick :: Maybe Text -> ModifyGuildMemberData+modifyGuildMemberNick v = ModifyGuildMemberData $ H.fromList [("nick", toJSON v)]++modifyGuildMemberRoles :: Maybe [Snowflake Role] -> ModifyGuildMemberData+modifyGuildMemberRoles v = ModifyGuildMemberData $ H.fromList [("roles", toJSON v)]++modifyGuildMemberMute :: Maybe Bool -> ModifyGuildMemberData+modifyGuildMemberMute v = ModifyGuildMemberData $ H.fromList [("mute", toJSON v)]++modifyGuildMemberDeaf :: Maybe Bool -> ModifyGuildMemberData+modifyGuildMemberDeaf v = ModifyGuildMemberData $ H.fromList [("deaf", toJSON v)]++modifyGuildMemberChannelID :: Maybe (Snowflake VoiceChannel) -> ModifyGuildMemberData+modifyGuildMemberChannelID v = ModifyGuildMemberData $ H.fromList [("channel_id", toJSON v)]++data CreateGuildBanData = CreateGuildBanData+  { deleteMessageDays :: Maybe Integer+  , reason :: Maybe Text+  }+  deriving (Show, Generic, Default)++-- | Parameters to the Modify Guild Role endpoint.+--+-- Use the provided methods (@modifyGuildRoleX@) to create a value with the+-- field set, use the Semigroup instance to union the values.+--+-- ==== Examples+--+-- >>> encode $ modifyGuildRoleName (Just "test") <> modifyGuildRolePermissions Nothing+-- "{\"name\":\"test\",\"permissions\":null}"+newtype ModifyGuildRoleData = ModifyGuildRoleData Object+    deriving (Show, Generic)+    deriving newtype (ToJSON, Semigroup, Monoid)+++modifyGuildRoleName :: Maybe Text -> ModifyGuildRoleData+modifyGuildRoleName v = ModifyGuildRoleData $ H.fromList [("name", toJSON v)]++modifyGuildRolePermissions :: Maybe Permissions -> ModifyGuildRoleData+modifyGuildRolePermissions v = ModifyGuildRoleData $ H.fromList [("permissions", toJSON v)]++modifyGuildRoleColour :: Maybe (Colour Double) -> ModifyGuildRoleData+modifyGuildRoleColour v = ModifyGuildRoleData $ H.fromList [("colour", toJSON v)]++modifyGuildRoleHoist :: Maybe Bool -> ModifyGuildRoleData+modifyGuildRoleHoist v = ModifyGuildRoleData $ H.fromList [("hoist", toJSON v)]++modifyGuildRoleMentionable :: Maybe Bool -> ModifyGuildRoleData+modifyGuildRoleMentionable v = ModifyGuildRoleData $ H.fromList [("mentionable", toJSON v)]++data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData+  { id :: Snowflake Role+  , position :: Maybe Integer+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON ModifyGuildRolePositionsData++data GuildRequest a where+  CreateGuild :: CreateGuildData -> GuildRequest Guild+  GetGuild :: HasID Guild g => g -> GuildRequest Guild+  ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild+  DeleteGuild :: HasID Guild g => g -> GuildRequest ()+  GetGuildChannels :: HasID Guild g => g -> GuildRequest [Channel]+  CreateGuildChannel :: HasID Guild g => g -> ChannelCreateData -> GuildRequest Channel+  ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest ()+  GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member+  ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member]+  AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member)+  ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest ()+  ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest ()+  AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest ()+  RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest ()+  RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest ()+  GetGuildBans :: HasID Guild g => g -> GuildRequest [BanData]+  GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData+  CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest ()+  RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest ()+  GetGuildRoles :: HasID Guild g => g -> GuildRequest [Role]+  CreateGuildRole :: HasID Guild g => g -> ModifyGuildRoleData -> GuildRequest Role+  ModifyGuildRolePositions :: HasID Guild g => g -> ModifyGuildRolePositionsData -> GuildRequest [Role]+  ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role+  DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest ()+  GetGuildPruneCount :: HasID Guild g => g -> Integer -> GuildRequest Integer+  BeginGuildPrune :: HasID Guild g => g -> Integer -> Bool -> GuildRequest (Maybe Integer)+  GetGuildVoiceRegions :: HasID Guild g => g -> GuildRequest [VoiceRegion]+  GetGuildInvites :: HasID Guild g => g -> GuildRequest [Invite]++baseRoute :: Snowflake Guild -> RouteBuilder _+baseRoute id =+  mkRouteBuilder // S "guilds" // ID @Guild+    & giveID id++instance Request (GuildRequest a) where+  type Result (GuildRequest a) = a++  route (CreateGuild _) =+    mkRouteBuilder // S "guilds"+      & buildRoute+  route (GetGuild (getID -> gid)) =+    baseRoute gid+      & buildRoute+  route (ModifyGuild (getID -> gid) _) =+    baseRoute gid+      & buildRoute+  route (DeleteGuild (getID -> gid)) =+    baseRoute gid+      & buildRoute+  route (GetGuildChannels (getID -> gid)) =+    baseRoute gid // S "channels"+      & buildRoute+  route (CreateGuildChannel (getID -> gid) _) =+    baseRoute gid // S "channels"+      & buildRoute+  route (ModifyGuildChannelPositions (getID -> gid) _) =+    baseRoute gid // S "channels"+      & buildRoute+  route (GetGuildMember (getID -> gid) (getID @User -> uid)) =+    baseRoute gid // S "members" // ID @User+      & giveID uid+      & buildRoute+  route (ListGuildMembers (getID -> gid) _) =+    baseRoute gid // S "members"+      & buildRoute+  route (AddGuildMember (getID -> gid) (getID @User -> uid) _) =+    baseRoute gid // S "members" // ID @User+      & giveID uid+      & buildRoute+  route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) =+    baseRoute gid // S "members" // ID @User+      & giveID uid+      & buildRoute+  route (ModifyCurrentUserNick (getID -> gid) _) =+    baseRoute gid // S "members" // S "@me" // S "nick"+      & buildRoute+  route (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) =+    baseRoute gid // S "members" // ID @User // S "roles" // ID @Role+      & giveID uid+      & giveID rid+      & buildRoute+  route (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) =+    baseRoute gid // S "members" // ID @User // S "roles" // ID @Role+      & giveID uid+      & giveID rid+      & buildRoute+  route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) =+    baseRoute gid // S "members" // ID @User+      & giveID uid+      & buildRoute+  route (GetGuildBans (getID -> gid)) =+    baseRoute gid // S "bans"+      & buildRoute+  route (GetGuildBan (getID -> gid) (getID @User -> uid)) =+    baseRoute gid // S "bans" // ID @User+      & giveID uid+      & buildRoute+  route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) =+    baseRoute gid // S "bans" // ID @User+      & giveID uid+      & buildRoute+  route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) =+    baseRoute gid // S "bans" // ID @User+      & giveID uid+      & buildRoute+  route (GetGuildRoles (getID -> gid)) =+    baseRoute gid // S "roles"+      & buildRoute+  route (CreateGuildRole (getID -> gid) _) =+    baseRoute gid // S "roles"+      & buildRoute+  route (ModifyGuildRolePositions (getID -> gid) _) =+    baseRoute gid // S "roles"+      & buildRoute+  route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) =+    baseRoute gid // S "roles" // ID @Role+      & giveID rid+      & buildRoute+  route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) =+    baseRoute gid // S "roles" // ID @Role+      & giveID rid+      & buildRoute+  route (GetGuildPruneCount (getID -> gid) _) =+    baseRoute gid // S "prune"+      & buildRoute+  route (BeginGuildPrune (getID -> gid) _ _) =+    baseRoute gid // S "prune"+      & buildRoute+  route (GetGuildVoiceRegions (getID -> gid)) =+    baseRoute gid // S "regions"+      & buildRoute+  route (GetGuildInvites (getID -> gid)) =+    baseRoute gid // S "invites"+      & buildRoute++  action (CreateGuild o) = postWith' (ReqBodyJson o)+  action (GetGuild _) = getWith+  action (ModifyGuild _ o) = patchWith' (ReqBodyJson o)+  action (DeleteGuild _) = deleteWith+  action (GetGuildChannels _) = getWith+  action (CreateGuildChannel _ o) = postWith' (ReqBodyJson o)+  action (ModifyGuildChannelPositions _ o) = postWith' (ReqBodyJson o)+  action (GetGuildMember _ _) = getWith+  action (ListGuildMembers _ ListMembersOptions{limit, after}) =+    getWithP+      ("limit" =:? (showt <$> limit) <> "after" =:? (showt <$> after))+  action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o)+  action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o)+  action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ object ["nick" .= nick])+  action AddGuildMemberRole{} = putEmpty+  action RemoveGuildMemberRole{} = deleteWith+  action (RemoveGuildMember _ _) = deleteWith+  action (GetGuildBans _) = getWith+  action (GetGuildBan _ _) = getWith+  action (CreateGuildBan _ _ CreateGuildBanData{deleteMessageDays, reason}) =+    putEmptyP+      ("delete-message-days" =:? (showt <$> deleteMessageDays) <> "reason" =:? (showt <$> reason))+  action (RemoveGuildBan _ _) = deleteWith+  action (GetGuildRoles _) = getWith+  action (CreateGuildRole _ o) = postWith' (ReqBodyJson o)+  action (ModifyGuildRolePositions _ o) = patchWith' (ReqBodyJson o)+  action (ModifyGuildRole _ _ o) = patchWith' (ReqBodyJson o)+  action (DeleteGuildRole _ _) = deleteWith+  action (GetGuildPruneCount _ d) = getWithP ("days" =: d)+  action (BeginGuildPrune _ d r) = postEmptyP ("days" =: d <> "compute_prune_count" =: r)+  action (GetGuildVoiceRegions _) = getWith+  action (GetGuildInvites _) = getWith++  -- this is a bit of a hack+  -- TODO: add something to allow for contextual parsing+  modifyResponse (GetGuildMember (getID @Guild -> gid) _) = _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid)+  modifyResponse (ListGuildMembers (getID @Guild -> gid) _) = values . _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid)+  modifyResponse _ = Prelude.id

@@ -0,0 +1,209 @@+-- | Module containing ratelimit stuff+module Calamity.HTTP.Internal.Ratelimit (+  newRateLimitState,+  doRequest,+) where++import Calamity.Client.Types (BotC)+import Calamity.HTTP.Internal.Route+import Calamity.HTTP.Internal.Types+import Calamity.Internal.Utils++import Control.Concurrent+import Control.Concurrent.Event (Event)+import qualified Control.Concurrent.Event as E+import Control.Concurrent.STM+import Control.Concurrent.STM.Lock (Lock)+import qualified Control.Concurrent.STM.Lock as L+import Control.Lens+import Control.Monad++import Data.Aeson+import Data.Aeson.Lens+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.Functor+import Data.Maybe+import qualified Data.Text.Lazy as LT+import Data.Time+import Data.Time.Clock.POSIX++import Fmt++import Focus++import Network.HTTP.Client (responseStatus)+import Network.HTTP.Date+import Network.HTTP.Req+import Network.HTTP.Types++import Polysemy (Sem)+import qualified Polysemy as P+import qualified Polysemy.Async as P++import Prelude hiding (error)++import qualified Control.Exception.Safe as Ex+import qualified StmContainers.Map as SC++newRateLimitState :: IO RateLimitState+newRateLimitState = RateLimitState <$> SC.newIO <*> E.newSet++lookupOrInsertDefaultM :: Monad m => m a -> Focus a m a+lookupOrInsertDefaultM aM =+  casesM+    ( do+        a <- aM+        pure (a, Set a)+    )+    (\a -> pure (a, Leave))++getRateLimit :: RateLimitState -> Route -> STM Lock+getRateLimit s h = SC.focus (lookupOrInsertDefaultM L.new) h (rateLimits s)++doDiscordRequest :: BotC r => IO LbsResponse -> Sem r DiscordResponseType+doDiscordRequest r = do+  r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException)+  case r'' of+    Right r' -> do+      let status = responseStatus . toVanillaResponse $ r'+      if+          | statusIsSuccessful status -> do+            let resp = responseBody r'+            debug $ "Got good response from discord: " +|| status ||+ ""+            pure $+              if isExhausted r'+                then case parseRateLimitHeader r' of+                  Just !sleepTime -> ExhaustedBucket resp sleepTime+                  Nothing -> ServerError (statusCode status)+                else Good resp+          | status == status429 -> do+            debug "Got 429 from discord, retrying."+            let resp = responseBody r'+            case resp ^? _Value of+              Just rv -> pure $ Ratelimited (parseRetryAfter rv) (isGlobal rv)+              Nothing -> pure $ ClientError (statusCode status) "429 with invalid json???"+          | statusIsClientError status -> do+            let err = responseBody r'+            error $ "Something went wrong: " +|| err ||+ " response: " +|| r' ||+ ""+            pure $ ClientError (statusCode status) err+          | otherwise -> do+            debug $ "Got server error from discord: " +| statusCode status |+ ""+            pure $ ServerError (statusCode status)+    Left e -> do+      error $ "Something went wrong with the http client: " +| LT.pack e |+ ""+      pure . InternalResponseError $ LT.pack e++parseDiscordTime :: ByteString -> Maybe UTCTime+parseDiscordTime s = httpDateToUTC <$> parseHTTPDate s++computeDiscordTimeDiff :: Double -> UTCTime -> Int+computeDiscordTimeDiff end !now = round . (* 1000.0) $! diffUTCTime end' now+ where+  !end' = end & toRational & fromRational & posixSecondsToUTCTime++-- | Parse a ratelimit header returning the number of milliseconds until it resets+parseRateLimitHeader :: HttpResponse r => r -> Maybe Int+parseRateLimitHeader r = computeDiscordTimeDiff <$> end <*> now+ where+  end = responseHeader r "X-Ratelimit-Reset" ^? _Just . _Double+  now = parseDiscordTime =<< responseHeader r "Date"++isExhausted :: HttpResponse r => r -> Bool+isExhausted r = responseHeader r "X-RateLimit-Remaining" == Just "0"++parseRetryAfter :: Value -> Int+parseRetryAfter r = r ^?! key "retry_after" . _Integral++isGlobal :: Value -> Bool+isGlobal r = r ^? key "global" . _Bool == Just True++-- Either (Either a a) b+data ShouldRetry a b+  = Retry a+  | RFail a+  | RGood b++retryRequest ::+  BotC r =>+  -- | number of retries+  Int ->+  -- | action to perform+  Sem r (ShouldRetry a b) ->+  -- | action to run if max number of retries was reached+  Sem r () ->+  Sem r (Either a b)+retryRequest max_retries action failAction = retryInner 0+ where+  retryInner num_retries = do+    res <- action+    case res of+      Retry r | num_retries > max_retries -> do+        debug $ "Request failed after " +| max_retries |+ " retries."+        doFail $ Left r+      Retry _ -> retryInner (num_retries + 1)+      RFail r -> do+        debug "Request failed due to error response."+        doFail $ Left r+      RGood r -> pure $ Right r+   where+    doFail v = failAction $> v++-- Run a single request+-- NOTE: this function will only unlock the ratelimit lock if the request+-- gave a response, otherwise it will stay locked so that it can be retried again+doSingleRequest ::+  BotC r =>+  -- | Global lock+  Event ->+  -- | Local lock+  Lock ->+  -- | Request action+  IO LbsResponse ->+  Sem r (ShouldRetry RestError LB.ByteString)+doSingleRequest gl l r = do+  r' <- doDiscordRequest r+  case r' of+    Good v -> do+      P.embed . atomically $ L.release l+      pure $ RGood v+    ExhaustedBucket v d -> do+      debug $ "Exhausted bucket, unlocking after " +| d |+ "ms"+      void . P.async $ do+        P.embed $ do+          threadDelay $ 1000 * d+          atomically $ L.release l+        debug "unlocking bucket"+      pure $ RGood v+    Ratelimited d False -> do+      debug $ "429 ratelimited on route, sleeping for " +| d |+ " ms"+      P.embed . threadDelay $ 1000 * d+      pure $ Retry (HTTPError 429 Nothing)+    Ratelimited d True -> do+      debug "429 ratelimited globally"+      P.embed $ do+        E.clear gl+        threadDelay $ 1000 * d+        E.set gl+      pure $ Retry (HTTPError 429 Nothing)+    ServerError c -> do+      debug "Server failed, retrying"+      pure $ Retry (HTTPError c Nothing)+    InternalResponseError c -> do+      debug "Internal error, retrying"+      pure $ Retry (InternalClientError c)+    ClientError c v -> pure $ RFail (HTTPError c $ decode v)++doRequest :: BotC r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString)+doRequest rlState route action = do+  P.embed $ E.wait (globalLock rlState)++  ratelimit <- P.embed . atomically $ do+    lock <- getRateLimit rlState route+    L.acquire lock+    pure lock++  retryRequest+    5+    (doSingleRequest (globalLock rlState) ratelimit action)+    (P.embed . atomically $ L.release ratelimit)

@@ -0,0 +1,145 @@+-- | Generic Request type+module Calamity.HTTP.Internal.Request (+  Request (..),+  invoke,+  getWith,+  postWith',+  postWithP',+  putWith',+  patchWith',+  putEmpty,+  putEmptyP,+  postEmpty,+  postEmptyP,+  getWithP,+  deleteWith,+  (=:?),+) where++import Calamity.Client.Types+import Calamity.HTTP.Internal.Ratelimit+import Calamity.HTTP.Internal.Route+import Calamity.HTTP.Internal.Types+import Calamity.Metrics.Eff+import Calamity.Types.Token++import Control.Lens+import Control.Monad++import Data.Aeson hiding (Options)+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Encoding as TS+import qualified Data.Text.Lazy as TL++import DiPolysemy hiding (debug, error, info)++import Network.HTTP.Req++import Polysemy (Sem)+import qualified Polysemy as P+import qualified Polysemy.Error as P+import qualified Polysemy.Reader as P++fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a+fromResult (Success a) = pure a+fromResult (Error e) = P.throw (InternalClientError . TL.pack $ e)++fromJSONDecode :: P.Member (P.Error RestError) r => Either String a -> Sem r a+fromJSONDecode (Right a) = pure a+fromJSONDecode (Left e) = P.throw (InternalClientError . TL.pack $ e)++extractRight :: P.Member (P.Error e) r => Either e a -> Sem r a+extractRight (Left e) = P.throw e+extractRight (Right a) = pure a++class ReadResponse a where+  readResp :: LB.ByteString -> Either String a++instance ReadResponse () where+  readResp = const (Right ())++instance {-# OVERLAPS #-} FromJSON a => ReadResponse a where+  readResp = eitherDecode++class Request a where+  type Result a++  route :: a -> Route++  action :: a -> Url 'Https -> Option 'Https -> Req LbsResponse++  modifyResponse :: a -> Value -> Value+  modifyResponse _ = id++invoke :: (BotC r, Request a, FromJSON (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a))+invoke a = do+  rlState' <- P.asks (^. #rlState)+  token' <- P.asks (^. #token)++  let route' = route a++  inFlightRequests <- registerGauge "inflight_requests" [("route", renderUrl $ route' ^. #path)]+  totalRequests <- registerCounter "total_requests" [("route", renderUrl $ route' ^. #path)]+  void $ modifyGauge (+ 1) inFlightRequests+  void $ addCounter 1 totalRequests++  let r = action a (route' ^. #path) (requestOptions token')+      act = runReq reqConfig r++  resp <- attr "route" (renderUrl $ route' ^. #path) $ doRequest rlState' route' act++  void $ modifyGauge (subtract 1) inFlightRequests++  P.runError $ fromResult . fromJSON . modifyResponse a =<< fromJSONDecode . readResp =<< extractRight resp++reqConfig :: HttpConfig+reqConfig =+  defaultHttpConfig+    { httpConfigCheckResponse = \_ _ _ -> Nothing+    }++defaultRequestOptions :: Option 'Https+defaultRequestOptions =+  header "User-Agent" "Calamity (https://github.com/simmsb/calamity)"+    <> header "X-RateLimit-Precision" "millisecond"++requestOptions :: Token -> Option 'Https+requestOptions t = defaultRequestOptions <> header "Authorization" (TS.encodeUtf8 . TL.toStrict $ formatToken t)++getWith :: Url 'Https -> Option 'Https -> Req LbsResponse+getWith u = req GET u NoReqBody lbsResponse++postWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse+postWith' a u = req POST u a lbsResponse++postWithP' :: HttpBody a => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse+postWithP' a o u o' = req POST u a lbsResponse (o <> o')++postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse+postEmpty u = req POST u NoReqBody lbsResponse++putWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse+putWith' a u = req PUT u a lbsResponse++patchWith' :: HttpBody a => a -> Url 'Https -> Option 'Https -> Req LbsResponse+patchWith' a u = req PATCH u a lbsResponse++putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse+putEmpty u = req PUT u NoReqBody lbsResponse++putEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse+putEmptyP o u o' = req PUT u NoReqBody lbsResponse (o <> o')++postEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse+postEmptyP o u o' = req POST u NoReqBody lbsResponse (o <> o')++getWithP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse+getWithP o u o' = req GET u NoReqBody lbsResponse (o <> o')++deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse+deleteWith u = req DELETE u NoReqBody lbsResponse++(=:?) :: T.Text -> Maybe T.Text -> Option 'Https+n =:? (Just x) = n =: x+n =:? Nothing = mempty

@@ -0,0 +1,148 @@+-- | The route type+-- Why I did this I don't know+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Calamity.HTTP.Internal.Route+    ( mkRouteBuilder+    , giveID+    , buildRoute+    , RouteBuilder+    , RouteRequirement+    , Route(path)+    , S(..)+    , ID(..)+    , RouteFragmentable(..) ) where++import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Snowflake++import           Data.Hashable+import           Data.Kind+import           Data.Maybe                   ( fromJust )+import           Data.Text                    ( Text )+import qualified Data.Text                    as T+import           Data.Typeable+import           Data.Word+import           Data.List ( foldl' )++import           Network.HTTP.Req++import           GHC.Generics                 hiding ( S )++import           TextShow++data RouteFragment+  = S' Text+  | ID' TypeRep+  deriving ( Generic, Show, Eq )++newtype S = S Text++data ID a = ID++instance Hashable RouteFragment++data RouteRequirement+  = NotNeeded+  | Required+  | Satisfied+  deriving ( Generic, Show, Eq )++data RouteBuilder (idState :: [(Type, RouteRequirement)]) = UnsafeMkRouteBuilder+  { route :: [RouteFragment]+  , ids   :: [(TypeRep, Word64)]+  }++mkRouteBuilder :: RouteBuilder '[]+mkRouteBuilder = UnsafeMkRouteBuilder [] []++giveID+  :: forall k ids+   . Typeable k+  => Snowflake k+  -> RouteBuilder ids+  -> RouteBuilder ('(k, 'Satisfied) ': ids)+giveID (Snowflake id) (UnsafeMkRouteBuilder route ids) =+  UnsafeMkRouteBuilder route ((typeRep (Proxy @k), id) : ids)++type family (&&) (a :: Bool) (b :: Bool) :: Bool where+  'True && 'True = 'True+  _     && _     = 'False++type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where+  Lookup k ('(k, v) ': xs) = 'Just v+  Lookup k ('(_, v) ': xs) = Lookup k xs+  Lookup _ '[]             = 'Nothing++type family IsElem (x :: k) (l :: [k]) :: Bool where+  IsElem _ '[]      = 'False+  IsElem k (k : _)  = 'True+  IsElem k (_ : xs) = IsElem k xs++type family EnsureFulfilled (ids :: [(k, RouteRequirement)]) :: Constraint where+  EnsureFulfilled ids = EnsureFulfilledInner ids '[] 'True++type family EnsureFulfilledInner (ids :: [(k, RouteRequirement)]) (seen :: [k]) (ok :: Bool) :: Constraint where+  EnsureFulfilledInner '[]                      _    'True = ()+  EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok+  EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok+  EnsureFulfilledInner ('(k, 'Required)  ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok)++type family AddRequired k (ids :: [(Type, RouteRequirement)]) :: [(Type, RouteRequirement)] where+  AddRequired k ids = '(k, AddRequiredInner (Lookup k ids)) ': ids++type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where+  AddRequiredInner ('Just 'Required)  = 'Required+  AddRequiredInner ('Just 'Satisfied) = 'Satisfied+  AddRequiredInner ('Just 'NotNeeded) = 'Required+  AddRequiredInner 'Nothing           = 'Required++class Typeable a => RouteFragmentable a ids where+  type ConsRes a ids++  (//) :: RouteBuilder ids -> a -> ConsRes a ids++instance RouteFragmentable S ids where+  type ConsRes S ids = RouteBuilder ids++  (UnsafeMkRouteBuilder r ids) // (S t) =+    UnsafeMkRouteBuilder (r <> [S' t]) ids++instance Typeable a => RouteFragmentable (ID (a :: Type)) (ids :: [(Type, RouteRequirement)]) where+  type ConsRes (ID a) ids = RouteBuilder (AddRequired a ids)++  (UnsafeMkRouteBuilder r ids) // ID =+    UnsafeMkRouteBuilder (r <> [ID' (typeRep (Proxy @a))]) ids++infixl 5 //++data Route = Route+  { path      :: Url 'Https+  , key       :: Text+  , channelID :: Maybe (Snowflake Channel)+  , guildID   :: Maybe (Snowflake Guild)+  } deriving (Generic, Show, Eq)++instance Hashable Route where+  hashWithSalt s (Route _ ident c g) = hashWithSalt s (ident, c, g)++baseURL :: Url 'Https+baseURL = https "discord.com" /: "api" /: "v8"++buildRoute+  :: forall (ids :: [(Type, RouteRequirement)])+   . EnsureFulfilled ids+  => RouteBuilder ids+  -> Route+buildRoute (UnsafeMkRouteBuilder route ids) = Route+  (foldl' (/:) baseURL $ map goR route)+  (T.concat (map goIdent route))+  (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids)+  (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids)+ where+  goR (S'  t) = t+  goR (ID' t) = showt . fromJust $ lookup t ids++  goIdent (S'  t) = t+  goIdent (ID' t) = showt t

@@ -0,0 +1,61 @@+-- | Types for the http lib+module Calamity.HTTP.Internal.Types+    ( RestError(..)+    , RateLimitState(..)+    , DiscordResponseType(..)+    , GatewayResponse+    , BotGatewayResponse ) where++import           Calamity.HTTP.Internal.Route+import           Calamity.Internal.AesonThings++import           Control.Concurrent.Event      ( Event )+import           Control.Concurrent.STM.Lock   ( Lock )++import           Data.Aeson+import qualified Data.ByteString.Lazy          as LB+import           Data.Text.Lazy++import           GHC.Generics++import qualified StmContainers.Map             as SC++data RestError+  -- | An error response from discord+  = HTTPError+      { status   :: Int+      , response :: Maybe Value+      }+  -- | Something failed while making the request (after retrying a few times)+  | InternalClientError Text+  deriving ( Show, Generic )++data RateLimitState = RateLimitState+  { rateLimits :: SC.Map Route Lock+  , globalLock :: Event+  }+  deriving ( Generic )++data DiscordResponseType+  = Good LB.ByteString -- ^ A good response+  | ExhaustedBucket -- ^ We got a response but also exhausted the bucket+      LB.ByteString Int -- ^ Retry after (milliseconds)+  | Ratelimited -- ^ We hit a 429, no response and ratelimited+      Int -- ^ Retry after (milliseconds)+      Bool -- ^ Global ratelimit+  | ServerError Int -- ^ Discord's error, we should retry (HTTP 5XX)+  | ClientError Int LB.ByteString -- ^ Our error, we should fail+  | InternalResponseError Text -- ^ Something went wrong with the http client++newtype GatewayResponse = GatewayResponse+  { url :: Text+  }+  deriving ( Generic, Show )+  deriving ( FromJSON ) via CalamityJSON GatewayResponse++data BotGatewayResponse = BotGatewayResponse+  { url    :: Text+  , shards :: Int+  }+  deriving ( Generic, Show )+  deriving ( FromJSON ) via CalamityJSON BotGatewayResponse

@@ -0,0 +1,32 @@+-- | Invite endpoints+module Calamity.HTTP.Invite (InviteRequest (..)) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Types.Model.Guild++import Control.Lens hiding ((.=))++import Data.Text (Text)++import Network.HTTP.Req++data InviteRequest a where+  GetInvite :: Text -> InviteRequest Invite+  DeleteInvite :: Text -> InviteRequest ()++baseRoute :: RouteBuilder _+baseRoute = mkRouteBuilder // S "invites"++instance Request (InviteRequest a) where+  type Result (InviteRequest a) = a++  route (GetInvite c) =+    baseRoute // S c+      & buildRoute+  route (DeleteInvite c) =+    baseRoute // S c+      & buildRoute++  action (GetInvite _) = getWithP ("with_counts" =: True)+  action (DeleteInvite _) = deleteWith

@@ -0,0 +1,25 @@+-- | Miscellaneous routes+module Calamity.HTTP.MiscRoutes where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.HTTP.Internal.Types++import Data.Function++data MiscRequest a where+  GetGateway :: MiscRequest GatewayResponse+  GetGatewayBot :: MiscRequest BotGatewayResponse++instance Request (MiscRequest a) where+  type Result (MiscRequest a) = a++  route GetGateway =+    mkRouteBuilder // S "gateway"+      & buildRoute+  route GetGatewayBot =+    mkRouteBuilder // S "gateway" // S "bot"+      & buildRoute++  action GetGateway = getWith+  action GetGatewayBot = getWith

@@ -0,0 +1,29 @@+-- | A wrapper request that adds a reson to a request+module Calamity.HTTP.Reason (+  Reason (..),+  reason,+) where++import Calamity.HTTP.Internal.Request++import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)++import GHC.Generics++import Network.HTTP.Req++data Reason a = Reason a Text+  deriving (Show, Eq, Generic)++-- | Attach a reason to a request+reason :: Request a => Text -> a -> Reason a+reason = flip Reason++instance Request a => Request (Reason a) where+  type Result (Reason a) = Result a++  route (Reason a _) = route a++  action (Reason a r) = \u o ->+    action a u (o <> header "X-Audit-Log-Reason" (encodeUtf8 r))

@@ -0,0 +1,87 @@+-- | User endpoints+module Calamity.HTTP.User (+  UserRequest (..),+  ModifyUserData (..),+  GetCurrentUserGuildsOptions (..),+) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.AesonThings+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Model.User+import Calamity.Types.Snowflake++import Control.Lens hiding ((.=))++import Data.Aeson+import Data.Default.Class+import Data.Text (Text)++import GHC.Generics++import Network.HTTP.Req++import TextShow++data ModifyUserData = ModifyUserData+  { username :: Maybe Text+  , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data+    avatar :: Maybe Text+  }+  deriving (Show, Generic, Default)+  deriving (ToJSON) via CalamityJSON ModifyUserData++data GetCurrentUserGuildsOptions = GetCurrentUserGuildsOptions+  { before :: Maybe (Snowflake Guild)+  , after :: Maybe (Snowflake Guild)+  , limit :: Maybe Integer+  }+  deriving (Show, Generic, Default)++data UserRequest a where+  GetCurrentUser :: UserRequest User+  GetUser :: HasID User u => u -> UserRequest User+  ModifyCurrentUser :: ModifyUserData -> UserRequest User+  GetCurrentUserGuilds :: GetCurrentUserGuildsOptions -> UserRequest [Partial Guild]+  LeaveGuild :: HasID Guild g => g -> UserRequest ()+  CreateDM :: HasID User u => u -> UserRequest DMChannel++baseRoute :: RouteBuilder _+baseRoute = mkRouteBuilder // S "users" // S "@me"++instance Request (UserRequest a) where+  type Result (UserRequest a) = a++  route GetCurrentUser =+    baseRoute+      & buildRoute+  route (GetUser (getID @User -> uid)) =+    mkRouteBuilder // S "users" // ID @User+      & giveID uid+      & buildRoute+  route (ModifyCurrentUser _) =+    baseRoute+      & buildRoute+  route (GetCurrentUserGuilds _) =+    baseRoute // S "guilds"+      & buildRoute+  route (LeaveGuild (getID @Guild -> gid)) =+    baseRoute // S "guilds" // ID @Guild+      & giveID gid+      & buildRoute+  route (CreateDM _) =+    baseRoute // S "channels"+      & buildRoute++  action GetCurrentUser = getWith+  action (GetUser _) = getWith+  action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o+  action (GetCurrentUserGuilds GetCurrentUserGuildsOptions{before, after, limit}) =+    getWithP+      ( "before" =:? (showt <$> before) <> "after" =:? (showt <$> after)+          <> "limit" =:? (showt <$> limit)+      )+  action (LeaveGuild _) = deleteWith+  action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (object ["recipient_id" .= uid])

@@ -0,0 +1,136 @@+-- | Webhook endpoints+module Calamity.HTTP.Webhook (+  WebhookRequest (..),+  CreateWebhookData (..),+  ModifyWebhookData (..),+  ExecuteWebhookOptions (..),+) where++import Calamity.HTTP.Internal.Request+import Calamity.HTTP.Internal.Route+import Calamity.Internal.AesonThings+import Calamity.Types.Model.Channel+import Calamity.Types.Model.Guild+import Calamity.Types.Snowflake++import Control.Lens hiding ((.=))++import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.Default.Class+import Data.Generics.Product.Subtype (upcast)+import Data.Text (Text)++import GHC.Generics++import Network.HTTP.Req++import Network.HTTP.Client.MultipartFormData+import TextShow++data CreateWebhookData = CreateWebhookData+  { username :: Maybe Text+  , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data+    avatar :: Maybe Text+  }+  deriving (Show, Generic, Default)+  deriving (ToJSON) via CalamityJSON CreateWebhookData++data ModifyWebhookData = ModifyWebhookData+  { username :: Maybe Text+  , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data+    avatar :: Maybe Text+  , channelID :: Maybe (Snowflake Channel)+  }+  deriving (Show, Generic, Default)+  deriving (ToJSON) via CalamityJSON ModifyWebhookData++data ExecuteWebhookOptions = ExecuteWebhookOptions+  { wait :: Maybe Bool+  , content :: Maybe Text+  , file :: Maybe ByteString+  , embeds :: Maybe [Embed]+  , username :: Maybe Text+  , avatarUrl :: Maybe Text+  , tts :: Maybe Bool+  }+  deriving (Show, Generic, Default)++data ExecuteWebhookJson = ExecuteWebhookJson+  { content :: Maybe Text+  , embeds :: Maybe [Embed]+  , username :: Maybe Text+  , avatarUrl :: Maybe Text+  , tts :: Maybe Bool+  }+  deriving (Show, Generic)+  deriving (ToJSON) via CalamityJSON ExecuteWebhookJson++data WebhookRequest a where+  CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook+  GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook]+  GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook]+  GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook+  GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook+  ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook+  ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook+  DeleteWebhook :: HasID Webhook w => w -> WebhookRequest ()+  DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest ()+  ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest ()++baseRoute :: Snowflake Webhook -> RouteBuilder _+baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id++instance Request (WebhookRequest a) where+  type Result (WebhookRequest a) = a++  route (CreateWebhook (getID @Channel -> cid) _) =+    mkRouteBuilder // S "channels" // ID @Channel // S "webhooks"+      & giveID cid+      & buildRoute+  route (GetChannelWebhooks (getID @Channel -> cid)) =+    mkRouteBuilder // S "channels" // ID @Channel // S "webhooks"+      & giveID cid+      & buildRoute+  route (GetGuildWebhooks (getID @Guild -> gid)) =+    mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks"+      & giveID gid+      & buildRoute+  route (GetWebhook (getID @Webhook -> wid)) =+    baseRoute wid+      & buildRoute+  route (GetWebhookToken (getID @Webhook -> wid) t) =+    baseRoute wid // S t+      & buildRoute+  route (ModifyWebhook (getID @Webhook -> wid) _) =+    baseRoute wid+      & buildRoute+  route (ModifyWebhookToken (getID @Webhook -> wid) t _) =+    baseRoute wid // S t+      & buildRoute+  route (DeleteWebhook (getID @Webhook -> wid)) =+    baseRoute wid+      & buildRoute+  route (DeleteWebhookToken (getID @Webhook -> wid) t) =+    baseRoute wid // S t+      & buildRoute+  route (ExecuteWebhook (getID @Webhook -> wid) t _) =+    baseRoute wid // S t+      & buildRoute++  action (CreateWebhook _ o) = postWith' $ ReqBodyJson o+  action (GetChannelWebhooks _) = getWith+  action (GetGuildWebhooks _) = getWith+  action (GetWebhook _) = getWith+  action (GetWebhookToken _ _) = getWith+  action (ModifyWebhook _ o) = patchWith' $ ReqBodyJson o+  action (ModifyWebhookToken _ _ o) = patchWith' $ ReqBodyJson o+  action (DeleteWebhook _) = deleteWith+  action (DeleteWebhookToken _ _) = deleteWith+  action (ExecuteWebhook _ _ o@ExecuteWebhookOptions{file = Nothing}) =+    postWithP'+      (ReqBodyJson . upcast @ExecuteWebhookJson $ o)+      ("wait" =:? (showt <$> o ^. #wait))+  action (ExecuteWebhook _ _ wh@ExecuteWebhookOptions{file = Just f}) = \u o -> do+    body <- reqBodyMultipart [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ wh)]+    postWithP' body ("wait" =:? (showt <$> wh ^. #wait)) u o

@@ -0,0 +1,144 @@+module Calamity.Internal.AesonThings+    ( WithSpecialCases(..)+    , IfNoneThen+    , ExtractFieldFrom+    , ExtractFieldInto+    , ExtractFields+    , ExtractArrayField+    , DefaultToEmptyArray+    , DefaultToZero+    , DefaultToFalse+    , CalamityJSON(..)+    , CalamityJSONKeepNothing(..)+    , jsonOptions+    , jsonOptionsKeepNothing ) where++import           Control.Lens++import           Data.Aeson+import           Data.Aeson.Lens+import           Data.Aeson.Types      ( Parser )+import           Data.Kind+import           Data.Reflection       ( Reifies(..) )+import           Data.Text             ( Text )+import           Data.Text.Strict.Lens+import           Data.Typeable++import           GHC.Generics+import           GHC.TypeLits          ( KnownSymbol, symbolVal )+import           Control.Monad ((>=>))++textSymbolVal :: forall n. KnownSymbol n => Text+textSymbolVal = symbolVal @n Proxy ^. packed++data IfNoneThen label def+data ExtractFieldInto label field target+type ExtractFieldFrom label field = ExtractFieldInto label field label+data ExtractFields label fields+data ExtractArrayField label field+data MapFieldWith field ty++class PerformAction action where+  runAction :: Proxy action -> Object -> Parser Object++instance (Reifies d Value, KnownSymbol label) => PerformAction (IfNoneThen label d) where+  runAction _ o = do+    v <- o .:? textSymbolVal @label .!= reflect @d Proxy+    pure $ o & at (textSymbolVal @label) ?~ v++instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where+  runAction _ o =+    let v :: Maybe Value = o ^? ix (textSymbolVal @label) . _Object . ix (textSymbolVal @field)+    in pure $ o & at (textSymbolVal @target) .~ v++instance PerformAction (ExtractFields label '[]) where+  runAction _ = pure++instance (KnownSymbol field,+          PerformAction (ExtractFieldInto label field field),+          PerformAction (ExtractFields label fields)) =>+         PerformAction (ExtractFields label (field : fields)) where+  runAction _ = runAction (Proxy @(ExtractFieldInto label field field)) >=> runAction (Proxy @(ExtractFields label fields))++instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where+  runAction _ o = do+    a :: Maybe Array <- o .:? textSymbolVal @label+    case a of+      Just a' -> do+        a'' <- Array <$> traverse (withObject "extracting field" (.: textSymbolVal @field)) a'+        pure $ o & at (textSymbolVal @label) ?~ a''+      Nothing -> pure o++instance (KnownSymbol field, Reifies ty (Value -> Value)) => PerformAction (MapFieldWith field ty) where+  runAction _ o = pure (o & ix (textSymbolVal @field) %~ reflect @ty Proxy)++newtype WithSpecialCases (rules :: [Type]) a = WithSpecialCases a++class RunSpecialCase a where+  runSpecialCases :: Proxy a -> Object -> Parser Object++instance RunSpecialCase '[] where+  runSpecialCases _ = pure . id++instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where+  runSpecialCases _ o = do+    o' <- runSpecialCases (Proxy @xs) o+    runAction (Proxy @action) o'++instance (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a))+  => FromJSON (WithSpecialCases rules a) where+  parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do+    o' <- runSpecialCases (Proxy @rules) o+    WithSpecialCases <$> genericParseJSON jsonOptions (Object o')+++data DefaultToEmptyArray++instance Reifies DefaultToEmptyArray Value where+  reflect _ = Array mempty++data DefaultToZero++instance Reifies DefaultToZero Value where+  reflect _ = Number 0++data DefaultToFalse++instance Reifies DefaultToFalse Value where+  reflect _ = Bool False++newtype CalamityJSON a = CalamityJSON+  { unCalamityJSON :: a+  }++instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSON a) where+  toJSON = genericToJSON jsonOptions . unCalamityJSON++  toEncoding = genericToEncoding jsonOptions . unCalamityJSON++instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSON a) where+  parseJSON = fmap CalamityJSON . genericParseJSON jsonOptions++-- | version that keeps Nothing fields+newtype CalamityJSONKeepNothing a = CalamityJSONKeepNothing+  { unCalamityJSONKeepNothing :: a+  }++instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSONKeepNothing a) where+  toJSON = genericToJSON jsonOptionsKeepNothing . unCalamityJSONKeepNothing++  toEncoding = genericToEncoding jsonOptionsKeepNothing . unCalamityJSONKeepNothing++instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSONKeepNothing a) where+  parseJSON = fmap CalamityJSONKeepNothing . genericParseJSON jsonOptionsKeepNothing++jsonOptions :: Options+jsonOptions = defaultOptions { sumEncoding        = UntaggedValue+                             , fieldLabelModifier = camelTo2 '_' . filter (/= '_')+                             , omitNothingFields  = True }++jsonOptionsKeepNothing :: Options+jsonOptionsKeepNothing = defaultOptions { sumEncoding        = UntaggedValue+                                        , fieldLabelModifier = camelTo2 '_' . filter (/= '_')+                                        , omitNothingFields  = False }+

@@ -0,0 +1,84 @@+-- | A thing for storing the last N things with IDs+module Calamity.Internal.BoundedStore (+  BoundedStore,+  empty,+  addItem,+  getItem,+  dropItem,+) where++import Calamity.Internal.Utils+import Calamity.Types.Snowflake+import Control.Lens+import Control.Monad.State.Lazy+import Data.Default.Class+import Data.Generics.Labels ()+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Deque.Lazy (Deque)+import qualified Deque.Lazy as DQ+import GHC.Generics++data BoundedStore a = BoundedStore+  { itemQueue :: Deque (Snowflake a)+  , items :: HashMap (Snowflake a) a+  , limit :: Int+  , size :: Int+  }+  deriving (Show, Generic)++instance Foldable BoundedStore where+  foldr f i = foldr f i . H.elems . items++instance Default (BoundedStore a) where+  def = BoundedStore mempty mempty 1000 0++empty :: Int -> BoundedStore a+empty limit = BoundedStore mempty mempty limit 0++type instance Index (BoundedStore a) = Snowflake a++type instance IxValue (BoundedStore a) = a++instance HasID' a => Ixed (BoundedStore a)++instance HasID' a => At (BoundedStore a) where+  at k f m =+    f mv <&> \case+      Nothing -> maybe m (const (dropItem k m)) mv+      Just v -> addItem v m+   where+    mv = getItem k m+  {-# INLINE at #-}++addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a+addItem m = execState $ do+  unlessM (H.member (getID m) <$> use #items) $ do+    #itemQueue %= DQ.cons (getID m)+    #size += 1++  size <- use #size+  limit <- use #limit++  when (size > limit) $ do+    q <- use #itemQueue+    let Just (rid, q') = DQ.unsnoc q+    #itemQueue .= q'+    #items %= sans rid+    #size -= 1++  #items %= H.insert (getID m) m+{-# INLINE addItem #-}++getItem :: Snowflake a -> BoundedStore a -> Maybe a+getItem id s = H.lookup id (s ^. #items)+{-# INLINE getItem #-}++dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a+dropItem id = execState $ do+  whenM (H.member id <$> use #items) $ do+    #size -= 1++  #itemQueue %= DQ.filter (/= id)+  #items %= H.delete id+{-# INLINE dropItem #-}

@@ -0,0 +1,24 @@+-- | Get the constructor name of something+module Calamity.Internal.ConstructorName+    ( CtorName(..)+    , GCtorName(..) ) where++import           GHC.Generics++class GCtorName f where+  gctorName :: f a -> String++instance Constructor c => GCtorName (C1 c f) where+  gctorName = conName++instance GCtorName f => GCtorName (D1 d f) where+  gctorName (M1 a) = gctorName a++instance (GCtorName f, GCtorName g) => GCtorName (f :+: g) where+  gctorName (L1 a) = gctorName a+  gctorName (R1 a) = gctorName a++class CtorName a where+  ctorName :: a -> String+  default ctorName :: (Generic a, GCtorName (Rep a)) => a -> String+  ctorName = gctorName . from

@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | An orphan instnace to parse @'Data.Colour' 'Double'@ as a word64+module Calamity.Internal.IntColour+    ( colourToWord64+    , colourFromWord64 ) where++import           Data.Aeson+import           Data.Bits+import           Data.Colour+import           Data.Colour.SRGB ( RGB(RGB), sRGB24, toSRGB24 )+import           Data.Word        ( Word64 )++colourToWord64 :: Colour Double -> Word64+colourToWord64 c = let RGB r g b = toSRGB24 c+                       i         = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b+                   in i++colourFromWord64 :: Word64 -> Colour Double+colourFromWord64 i = let r = (i `shiftR` 16) .&. 0xff+                         g = (i `shiftR` 8) .&. 0xff+                         b = i .&. 0xff+                     in sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b)++instance ToJSON (Colour Double) where+  toJSON = toJSON . colourToWord64++instance FromJSON (Colour Double) where+  parseJSON v = colourFromWord64 <$> parseJSON v

@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}++-- | A Writer monad that supports local writing, reverse reader I guess?+module Calamity.Internal.LocalWriter+    ( LocalWriter(..)+    , ltell+    , llisten+    , runLocalWriter ) where++import qualified Polysemy       as P+import qualified Polysemy.State as P++data LocalWriter o m a where+  Ltell :: o -> LocalWriter o m ()+  Llisten :: m a -> LocalWriter o m (o, a)++P.makeSem ''LocalWriter++runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)+runLocalWriter = P.runState mempty . P.reinterpretH+  (\case+     Ltell o   -> do+       P.modify' (<> o) >>= P.pureT+     Llisten m -> do+       mm <- P.runT m+       (o, fa) <- P.raise $ runLocalWriter mm+       pure $ fmap (o, ) fa)

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Something for converting polysemy actions into IO actions+module Calamity.Internal.RunIntoIO+    ( runSemToIO+    , bindSemToIO ) where++import           Data.Functor++import qualified Polysemy                         as P+import qualified Polysemy.Final                   as P++runSemToIO :: forall r a. P.Member (P.Final IO) r => P.Sem r a -> P.Sem r (IO (Maybe a))+runSemToIO m = P.withStrategicToFinal $ do+  m' <- P.runS m+  ins <- P.getInspectorS+  P.liftS $ pure (P.inspect ins <$> m')++bindSemToIO :: forall r p a. P.Member (P.Final IO) r => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a))+bindSemToIO m = P.withStrategicToFinal $ do+  istate <- P.getInitialStateS+  m' <- P.bindS m+  ins <- P.getInspectorS+  P.liftS $ pure (\x -> P.inspect ins <$> m' (istate $> x))

@@ -0,0 +1,237 @@+-- | Module for custom instance of Data.HashMap.Strict that decodes from any list of objects that have an id field+module Calamity.Internal.SnowflakeMap where++import Calamity.Internal.Utils ()+import Calamity.Types.Snowflake+import Control.DeepSeq+import Control.Lens.At+import Control.Lens.Iso+import Control.Lens.Wrapped+import Data.Aeson (FromJSON (..), ToJSON (..), withArray)+import Data.Data+import qualified Data.Foldable as F+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as SH+import Data.Hashable+import GHC.Exts (IsList)+import GHC.Generics+import TextShow+import qualified TextShow.Generic as TSG+import Unsafe.Coerce++newtype SnowflakeMap a = SnowflakeMap+  { unSnowflakeMap :: HashMap (Snowflake a) a+  }+  deriving (Generic, Eq, Data, Ord, Show)+  deriving (TextShow) via TSG.FromGeneric (SnowflakeMap a)+  deriving newtype (IsList, Semigroup, Monoid)+  deriving newtype (NFData, Hashable)++-- instance At (SnowflakeMap a) where+--   at k f m = at (unSnowflakeMap k) f m++instance Functor SnowflakeMap where+  fmap f = SnowflakeMap . coerceSnowflakeMap . fmap f . unSnowflakeMap++instance Foldable SnowflakeMap where+  foldr f b = Prelude.foldr f b . unSnowflakeMap++instance Traversable SnowflakeMap where+  traverse f = fmap (SnowflakeMap . coerceSnowflakeMap) . traverse f . unSnowflakeMap++-- deriving instance NFData a => NFData (SnowflakeMap a)++-- deriving instance Hashable a => Hashable (SnowflakeMap a)++instance Wrapped (SnowflakeMap a) where+  type Unwrapped (SnowflakeMap a) = HashMap (Snowflake a) a++  _Wrapped' = iso unSnowflakeMap SnowflakeMap++type instance Index (SnowflakeMap a) = Snowflake a++type instance IxValue (SnowflakeMap a) = a++instance SnowflakeMap a ~ t => Rewrapped (SnowflakeMap b) a++instance Ixed (SnowflakeMap a) where+  ix i = _Wrapped . ix i++instance At (SnowflakeMap a) where+  at i = _Wrapped . at i++over :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b+over f = SnowflakeMap . f . unSnowflakeMap+{-# INLINEABLE over #-}++-- SAFETY: 'Snowflake' always uses the underlying hash function (Word64)+coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v+coerceSnowflakeMap = unsafeCoerce+{-# INLINEABLE coerceSnowflakeMap #-}++empty :: SnowflakeMap a+empty = SnowflakeMap SH.empty+{-# INLINEABLE empty #-}++singleton :: HasID' a => a -> SnowflakeMap a+singleton v = SnowflakeMap $ SH.singleton (getID v) v+{-# INLINEABLE singleton #-}++null :: SnowflakeMap a -> Bool+null = SH.null . unSnowflakeMap+{-# INLINEABLE null #-}++size :: SnowflakeMap a -> Int+size = SH.size . unSnowflakeMap+{-# INLINEABLE size #-}++member :: Snowflake a -> SnowflakeMap a -> Bool+member k = SH.member k . unSnowflakeMap+{-# INLINEABLE member #-}++lookup :: Snowflake a -> SnowflakeMap a -> Maybe a+lookup k = SH.lookup k . unSnowflakeMap+{-# INLINEABLE lookup #-}++lookupDefault :: a -> Snowflake a -> SnowflakeMap a -> a+lookupDefault d k = SH.lookupDefault d k . unSnowflakeMap+{-# INLINEABLE lookupDefault #-}++(!) :: SnowflakeMap a -> Snowflake a -> a+(!) m k = unSnowflakeMap m SH.! k+{-# INLINEABLE (!) #-}++infixl 9 !++insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a+insert v = over $ SH.insert (getID v) v+{-# INLINEABLE insert #-}++insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a+insertWith f v = over $ SH.insertWith f (getID v) v+{-# INLINEABLE insertWith #-}++delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a+delete k = over $ SH.delete k+{-# INLINEABLE delete #-}++adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a+adjust f k = over $ SH.adjust f k+{-# INLINEABLE adjust #-}++update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a+update f k = over $ SH.update f k+{-# INLINEABLE update #-}++alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a+alter f k = over $ SH.alter f k+{-# INLINEABLE alter #-}++union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+union m m' = SnowflakeMap $ SH.union (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE union #-}++unionWith :: (a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+unionWith f m m' = SnowflakeMap $ SH.unionWith f (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE unionWith #-}++unionWithKey :: (Snowflake a -> a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+unionWithKey f m m' = SnowflakeMap $ SH.unionWithKey f (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE unionWithKey #-}++unions :: [SnowflakeMap a] -> SnowflakeMap a+unions = SnowflakeMap . SH.unions . Prelude.map unSnowflakeMap+{-# INLINEABLE unions #-}++map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2+map f = over $ coerceSnowflakeMap . SH.map f+{-# INLINEABLE map #-}++mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2+mapWithKey f = over $ coerceSnowflakeMap . SH.mapWithKey f+{-# INLINEABLE mapWithKey #-}++traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2)+traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . SH.traverseWithKey f . unSnowflakeMap+{-# INLINEABLE traverseWithKey #-}++difference :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+difference m m' = SnowflakeMap $ SH.difference (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE difference #-}++differenceWith :: (a -> a -> Maybe a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+differenceWith f m m' = SnowflakeMap $ SH.differenceWith f (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE differenceWith #-}++intersection :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+intersection m m' = SnowflakeMap $ SH.intersection (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE intersection #-}++intersectionWith :: (a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b+intersectionWith f m m' = SnowflakeMap . coerceSnowflakeMap $ SH.intersectionWith f (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE intersectionWith #-}++intersectionWithKey :: (Snowflake a -> a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b+intersectionWithKey f m m' = SnowflakeMap . coerceSnowflakeMap $ SH.intersectionWithKey f (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINEABLE intersectionWithKey #-}++foldl' :: (a -> b -> a) -> a -> SnowflakeMap b -> a+foldl' f s m = SH.foldl' f s $ unSnowflakeMap m+{-# INLINEABLE foldl' #-}++foldlWithKey' :: (a -> Snowflake b -> b -> a) -> a -> SnowflakeMap b -> a+foldlWithKey' f s m = SH.foldlWithKey' f s $ unSnowflakeMap m+{-# INLINEABLE foldlWithKey' #-}++foldr :: (b -> a -> a) -> a -> SnowflakeMap b -> a+foldr f s m = SH.foldr f s $ unSnowflakeMap m+{-# INLINEABLE foldr #-}++foldrWithKey :: (Snowflake b -> b -> a -> a) -> a -> SnowflakeMap b -> a+foldrWithKey f s m = SH.foldrWithKey f s $ unSnowflakeMap m+{-# INLINEABLE foldrWithKey #-}++filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a+filter f = over $ SH.filter f+{-# INLINEABLE filter #-}++filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a+filterWithKey f = over $ SH.filterWithKey f+{-# INLINEABLE filterWithKey #-}++mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b+mapMaybe f = over $ coerceSnowflakeMap . SH.mapMaybe f+{-# INLINEABLE mapMaybe #-}++mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b+mapMaybeWithKey f = over $ coerceSnowflakeMap . SH.mapMaybeWithKey f+{-# INLINEABLE mapMaybeWithKey #-}++keys :: SnowflakeMap a -> [Snowflake a]+keys = SH.keys . unSnowflakeMap+{-# INLINEABLE keys #-}++elems :: SnowflakeMap a -> [a]+elems = SH.elems . unSnowflakeMap+{-# INLINEABLE elems #-}++toList :: SnowflakeMap a -> [(Snowflake a, a)]+toList = SH.toList . unSnowflakeMap+{-# INLINEABLE toList #-}++fromList :: HasID' a => [a] -> SnowflakeMap a+fromList = SnowflakeMap . SH.fromList . Prelude.map (\v -> (getID v, v))+{-# INLINEABLE fromList #-}++fromListWith :: HasID' a => (a -> a -> a) -> [a] -> SnowflakeMap a+fromListWith f = SnowflakeMap . SH.fromListWith f . Prelude.map (\v -> (getID v, v))+{-# INLINEABLE fromListWith #-}++instance (FromJSON a, HasID' a) => FromJSON (SnowflakeMap a) where+  parseJSON = withArray "SnowflakeMap" $ \l -> do+    parsed <- traverse parseJSON l+    pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed++instance ToJSON a => ToJSON (SnowflakeMap a) where+  toJSON = toJSON . elems+  toEncoding = toEncoding . elems

@@ -0,0 +1,98 @@+-- | Updateable objects+module Calamity.Internal.Updateable+    ( Updateable(..) ) where++import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Channel.UpdatedMessage+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.User++import           Control.Lens++import           Data.Generics.Product.Fields+import           Data.Maybe++import           GHC.TypeLits++class Updateable a where+  type Updated a+  type Updated a = a++  update :: Updated a -> a -> a++-- | sets original field to new field+setF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n b) => n -> o -> o+setF n = field' @f .~ (n ^. field' @f)++-- | sets original field to unwrapped new field if new field is not Nothing+mergeF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n (Maybe b)) => o -> n -> o -> o+mergeF o n = field' @f .~ fromMaybe (o ^. field' @f) (n ^. field' @f)++-- | sets original field to new field if new field is not Nothing+mergeF' :: forall (f :: Symbol) o n b. (HasField' f o (Maybe b), HasField' f n (Maybe b)) => o -> n -> o -> o+mergeF' o n = field' @f .~ lastMaybe (o ^. field' @f) (n ^. field' @f)++instance Updateable Message where+  type Updated Message = UpdatedMessage++  update n o = o+    & mergeF @"content" o n+    & setF @"editedTimestamp" n+    & mergeF @"tts" o n+    & mergeF @"mentionEveryone" o n+    & mergeF @"mentions" o n+    & mergeF @"mentionRoles" o n+    & mergeF' @"mentionChannels" o n+    & mergeF @"attachments" o n+    & mergeF @"embeds" o n+    & mergeF @"reactions" o n+    & mergeF @"pinned" o n++instance Updateable Channel where+  update n _ = n++instance Updateable DMChannel where+  update n _ = n++instance Updateable GuildChannel where+  update n _ = n++instance Updateable Guild where+  type Updated Guild = UpdatedGuild++  -- For updating guild we just put in the non-present data from+  update n o = o+    & setF @"name" n+    & setF @"icon" n+    & setF @"splash" n+    & setF @"owner" n+    & setF @"ownerID" n+    & mergeF @"permissions" o n+    & setF @"region" n+    & setF @"afkChannelID" n+    & setF @"afkTimeout" n+    & mergeF @"embedEnabled" o n+    & setF @"embedChannelID" n+    & setF @"verificationLevel" n+    & setF @"defaultMessageNotifications" n+    & setF @"explicitContentFilter" n+    & setF @"roles" n+    & setF @"features" n+    & setF @"mfaLevel" n+    & setF @"applicationID" n+    & mergeF @"widgetEnabled" o n+    & setF @"widgetChannelID" n+    & setF @"systemChannelID" n++instance Updateable User where+  update n o = o+    & setF @"username" n+    & setF @"discriminator" n+    & mergeF' @"bot" o n+    & mergeF' @"avatar" o n+    & mergeF' @"mfaEnabled" o n+    & mergeF' @"verified" o n+    & mergeF' @"email" o n+    & mergeF' @"flags" o n+    & mergeF' @"premiumType" o n

@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Internal utilities and instances+module Calamity.Internal.Utils+    ( whileMFinalIO+    , untilJustFinalIO+    , whenJust+    , whenM+    , unlessM+    , lastMaybe+    , leftToMaybe+    , rightToMaybe+    , justToEither+    , (<<$>>)+    , (<<*>>)+    , (<.>)+    , debug+    , info+    , Calamity.Internal.Utils.error+    , swap ) where++import           Calamity.Types.LogEff+import           Calamity.Internal.RunIntoIO++import           Control.Applicative++import           Data.Default.Class+import qualified Data.HashMap.Lazy     as LH+import qualified Data.Map              as M+import           Data.Semigroup        ( Last(..) )+import           Data.Text.Lazy+import           Data.Time+import qualified Data.Vector.Unboxing  as VU+import           Data.Vector.Unboxing  ( Vector )+import           Data.Aeson++import qualified DiPolysemy            as Di++import qualified Polysemy              as P++import           TextShow+import Data.Colour (Colour)++-- | Like whileM, but stateful effects are not preserved to mitigate memory leaks+--+-- This means Polysemy.Error won't work to break the loop, etc.+-- Instead, Error/Alternative will just result in the loop quitting.+whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r ()+whileMFinalIO action = do+  action' <- runSemToIO action+  P.embedFinal $ go action'+  where go action' = do+          r <- action'+          case r of+            Just True ->+              go action'+            _ ->+              pure ()++-- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks+--+-- This means Polysemy.Error won't work to break the loop, etc.+-- Instead, Error/Alternative will just result in another loop.+untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a+untilJustFinalIO action = do+  action' <- runSemToIO action+  P.embedFinal $ go action'+  where go action' = do+          r <- action'+          case r of+            Just (Just a) ->+              pure a+            _ ->+              go action'++whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust = flip $ maybe (pure ())++whenM :: Monad m => m Bool -> m () -> m ()+whenM p m = p >>= \case+  True  -> m+  False -> pure ()++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM = whenM . (not <$>)++lastMaybe :: Maybe a -> Maybe a -> Maybe a+lastMaybe l r = getLast <$> fmap Last l <> fmap Last r++leftToMaybe :: Either e a -> Maybe e+leftToMaybe (Left x) = Just x+leftToMaybe _        = Nothing++rightToMaybe :: Either e a -> Maybe a+rightToMaybe (Right x) = Just x+rightToMaybe _         = Nothing++justToEither :: Maybe e -> Either e ()+justToEither (Just x) = Left x+justToEither _        = Right ()++(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(<<$>>) = fmap . fmap++infixl 4 <<$>>++(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b)+(<<*>>) = liftA2 (<*>)++infixl 4 <<*>>++(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b)+(<.>) f g x = f <$> g x++infixl 4 <.>++debug :: P.Member LogEff r => Text -> P.Sem r ()+debug = Di.debug++info :: P.Member LogEff r => Text -> P.Sem r ()+info = Di.info++error :: P.Member LogEff r => Text -> P.Sem r ()+error = Di.error++swap :: (a, b) -> (b, a)+swap ~(a, b) = (b, a)++instance TextShow UTCTime where+  showb = fromString . show++instance (TextShow a, VU.Unboxable a) => TextShow (Vector a) where+  showb = showbList . VU.toList++instance (Show k, Show v) => TextShow (LH.HashMap k v) where+  showb = fromString . show++instance (Show k, Show v) => TextShow (M.Map k v) where+  showb = fromString . show++instance (Show a, Fractional a) => TextShow (Colour a) where+  showb = fromString . show++instance Default (M.Map k v) where+    def = M.empty++instance (FromJSON a, VU.Unboxable a) => FromJSON (VU.Vector a) where+  parseJSON = (VU.fromList <$>) . parseJSON++instance (ToJSON a, VU.Unboxable a) => ToJSON (VU.Vector a) where+  toJSON = toJSON . VU.toList+  toEncoding = toEncoding . VU.toList

@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Effect for handling metrics+module Calamity.Metrics.Eff+    ( Counter+    , Gauge+    , Histogram+    , HistogramSample(..)+    , MetricEff(..)+    , registerCounter+    , registerGauge+    , registerHistogram+    , addCounter+    , modifyGauge+    , observeHistogram ) where++import           Calamity.Internal.Utils   ()+import           Calamity.Metrics.Internal++import           Data.Default.Class+import           Data.Map+import           Data.Text++import           GHC.Generics++import           Polysemy++import           TextShow+import qualified TextShow.Generic          as TSG++data HistogramSample = HistogramSample+  { buckets :: Map Double Double+  , sum     :: Double+  , count   :: Int+  }+  deriving ( Eq, Show, Generic, Default )+  deriving ( TextShow ) via TSG.FromGeneric HistogramSample++data MetricEff m a where+  -- | Register a 'Counter'+  RegisterCounter :: Text -- ^ Name+    -> [(Text, Text)] -- ^ Labels+    -> MetricEff m Counter++  -- | Register a 'Gauge'+  RegisterGauge :: Text -- ^ Name+    -> [(Text, Text)] -- ^ Labels+    -> MetricEff m Gauge++  -- | Register a 'Histogram'+  RegisterHistogram :: Text -- ^ Name+    -> [(Text, Text)] -- ^ Labels+    -> [Double] -- ^ Upper bounds+    -> MetricEff m Histogram++  AddCounter :: Int -> Counter -> MetricEff m Int++  ModifyGauge :: (Double -> Double) -> Gauge -> MetricEff m Double++  ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample++makeSem ''MetricEff

@@ -0,0 +1,20 @@+-- | Internal data structures to the metrics effect+module Calamity.Metrics.Internal+    ( Counter(..)+    , Gauge(..)+    , Histogram(..) ) where++-- | A handle to a counter+newtype Counter = Counter+  { unCounter :: Int+  }++-- | A handle to a gauge+newtype Gauge = Gauge+  { unGauge :: Int+  }++-- | A handle to a histogram+newtype Histogram = Histogram+  { unHistogram :: Int+  }

@@ -0,0 +1,20 @@+-- | Noop handler for metrics+module Calamity.Metrics.Noop+    ( runMetricsNoop ) where++import           Calamity.Metrics.Eff+import           Calamity.Metrics.Internal++import           Data.Default.Class++import           Polysemy++runMetricsNoop :: Sem (MetricEff ': r) a -> Sem r a+runMetricsNoop = interpret $ \case+  RegisterCounter _ _     -> pure (Counter 0)+  RegisterGauge _ _       -> pure (Gauge 0)+  RegisterHistogram _ _ _ -> pure (Histogram 0)++  AddCounter _ _          -> pure def+  ModifyGauge _ _         -> pure def+  ObserveHistogram _ _    -> pure def

@@ -0,0 +1,30 @@+-- | All user facing types+module Calamity.Types+    ( module Calamity.Types.Model+    , module Calamity.Types.Partial+    , module Calamity.Types.Snowflake+    , module Calamity.Types.Token+    , module Calamity.Types.Tellable+    , module Calamity.Types.Upgradeable+    , module Calamity.Types.UnixTimestamp+    -- * Types+    -- $typesDocs+    ) where++import           Calamity.Types.Model+import           Calamity.Types.Partial+import           Calamity.Types.Snowflake+import           Calamity.Types.Token+import           Calamity.Types.Tellable+import           Calamity.Types.Upgradeable+import           Calamity.Types.UnixTimestamp++-- $typesDocs+--+-- This module collects all discord models, and other useful types together.+--+-- The 'Tellable' class allows you to construct and send+-- messages to things to you can send messages to in a neat way.+--+-- The 'Upgradeable' class allows you to upgrade a snowflake to the full value+-- it refers to.

@@ -0,0 +1,16 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | The logging effect we use+module Calamity.Types.LogEff+    ( LogEff+    , LogC ) where++import qualified Df1++import           DiPolysemy++import qualified Polysemy   as P++type LogEff = Di Df1.Level Df1.Path Df1.Message++type LogC r = P.Member LogEff r

@@ -0,0 +1,13 @@+-- | Discord data models+module Calamity.Types.Model+    ( module Calamity.Types.Model.Channel+    , module Calamity.Types.Model.Guild+    , module Calamity.Types.Model.Presence+    , module Calamity.Types.Model.User+    , module Calamity.Types.Model.Voice ) where++import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.Presence+import           Calamity.Types.Model.User+import           Calamity.Types.Model.Voice

@@ -0,0 +1,68 @@+-- | The generic channel type+module Calamity.Types.Model.Channel+    ( Channel(..)+    , Partial(PartialChannel)+    , module Calamity.Types.Model.Channel.DM+    , module Calamity.Types.Model.Channel.Group+    , module Calamity.Types.Model.Channel.Guild+    , module Calamity.Types.Model.Channel.Attachment+    , module Calamity.Types.Model.Channel.Reaction+    , module Calamity.Types.Model.Channel.Webhook+    , module Calamity.Types.Model.Channel.Embed+    , module Calamity.Types.Model.Channel.ChannelType+    , module Calamity.Types.Model.Channel.Message ) where++import           Calamity.Internal.AesonThings+import           Calamity.Types.Model.Channel.Attachment+import           Calamity.Types.Model.Channel.ChannelType+import           Calamity.Types.Model.Channel.DM+import           Calamity.Types.Model.Channel.Embed+import           Calamity.Types.Model.Channel.Group+import           Calamity.Types.Model.Channel.Guild+import {-# SOURCE #-} Calamity.Types.Model.Channel.Message+import           Calamity.Types.Model.Channel.Reaction+import           Calamity.Types.Model.Channel.Webhook+import           Calamity.Types.Partial+import           Calamity.Types.Snowflake++import           Data.Aeson+import           Data.Text.Lazy                           ( Text )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                         as TSG++data Channel+  = DMChannel' DMChannel+  | GroupChannel' GroupChannel+  | GuildChannel' GuildChannel+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Channel++instance HasID Channel Channel where+  getID (DMChannel' a) = getID a+  getID (GroupChannel' a) = getID a+  getID (GuildChannel' a) = getID a++instance FromJSON Channel where+  parseJSON = withObject "Channel" $ \v -> do+    type_ <- v .: "type"++    case type_ of+      GuildTextType     -> GuildChannel' <$> parseJSON (Object v)+      GuildVoiceType    -> GuildChannel' <$> parseJSON (Object v)+      GuildCategoryType -> GuildChannel' <$> parseJSON (Object v)+      DMType            -> DMChannel' <$> parseJSON (Object v)+      GroupDMType       -> GroupChannel' <$> parseJSON (Object v)++data instance Partial Channel = PartialChannel+  { id       :: Snowflake Channel+  , name     :: Text+  , type_    :: !ChannelType+  , parentID :: Maybe (Snowflake Category)+  }+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric (Partial Channel)+  deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Channel)+  deriving ( HasID Channel ) via HasIDField "id" (Partial Channel)

@@ -0,0 +1,7 @@+-- | The generic channel type+module Calamity.Types.Model.Channel+    ( Channel ) where++data Channel+instance Show Channel+instance Eq Channel

@@ -0,0 +1,50 @@+-- | Message attachments+module Calamity.Types.Model.Channel.Attachment+    ( Attachment(..) ) where++import           Calamity.Internal.AesonThings ()+import           Calamity.Types.Snowflake+import           Data.Aeson+import           Data.Text.Lazy                ( Text )+import           Data.Word+import           GHC.Generics+import           TextShow+import qualified TextShow.Generic              as TSG++fuseTup2 :: Monad f => (f a, f b) -> f (a, b)+fuseTup2 (a, b) = do+  !a' <- a+  !b' <- b+  pure (a', b')++data Attachment = Attachment+  { id         :: Snowflake Attachment+  , filename   :: !Text+  , size       :: Word64+  , url        :: !Text+  , proxyUrl   :: !Text+  , dimensions :: !(Maybe (Word64, Word64))+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Attachment+  deriving ( HasID Attachment ) via HasIDField "id" Attachment++instance ToJSON Attachment where+  toJSON Attachment { id, filename, size, url, proxyUrl, dimensions = Just (width, height) } = object+    [ "id" .= id+    , "filename" .= filename+    , "size" .= size+    , "url" .= url+    , "proxy_url" .= proxyUrl+    , "width" .= width+    , "height" .= height]+  toJSON Attachment { id, filename, size, url, proxyUrl } =+    object ["id" .= id, "filename" .= filename, "size" .= size, "url" .= url, "proxy_url" .= proxyUrl]++instance FromJSON Attachment where+  parseJSON = withObject "Attachment" $ \v -> do+    width <- v .:? "width"+    height <- v .:? "height"++    Attachment <$> v .: "id" <*> v .: "filename" <*> v .: "size" <*> v .: "url" <*> v .: "proxy_url" <*> pure+      (fuseTup2 (width, height))

@@ -0,0 +1,34 @@+-- | Types of channels+module Calamity.Types.Model.Channel.ChannelType+    ( ChannelType(..) ) where++import           Data.Aeson+import           Data.Scientific++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic as TSG++-- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182)+data ChannelType+  = GuildTextType+  | DMType+  | GuildVoiceType+  | GroupDMType+  | GuildCategoryType+  deriving ( Eq, Generic, Show, Enum )+  deriving ( TextShow ) via TSG.FromGeneric ChannelType++instance ToJSON ChannelType where+  toJSON t = Number $ fromIntegral (fromEnum t)++instance FromJSON ChannelType where+  parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of+    Just !v  -> case v of+      0 -> pure GuildTextType+      1 -> pure DMType+      2 -> pure GuildVoiceType+      4 -> pure GuildCategoryType+      _ -> fail $ "Invalid ChannelType: " <> show n+    Nothing -> fail $ "Invalid ChannelType: " <> show n