diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,8 +1,41 @@
-# Calamity
+Calamity
-A discord library for haskell
+
+
+
+
+
+ 
+ 
+ 
+ 
+
+
+Calamity is a Haskell library for writing discord bots, it uses
+[Polysemy](https://hackage.haskell.org/package/polysemy) as the core library for
+handling effects, allowing you to pick and choose how to handle certain features
+of the library.
+
+The current customisable effects are:
+
+* Cache: The default cache handler keeps the cache in memory, however you could
+ write a cache handler that stores cache in a database for example.
+
+* Metrics: The library has counters, gauges, and histograms installed to measure
+ useful things, by default these are not used (and cost nothing), but could be
+ combined with [Prometheus](https://hackage.haskell.org/package/prometheus). An
+ example of using prometheus as the metrics handler can be found
+ [here](https://github.com/nitros12/calamity-example).
+
+# Docs
+
+You can find documentation on hackage: [here](https://hackage.haskell.org/package/calamity)
+
# Example
+
+An example project can be found at:
+[nitros12/calamity-example](https://github.com/nitros12/calamity-example)
``` haskell
{-# LANGUAGE DataKinds #-}
diff --git a/calamity.cabal b/calamity.cabal
--- a/calamity.cabal
+++ b/calamity.cabal
@@ -1,13 +1,13 @@
cabal-version: 1.18
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
--- hash: 7abac2efea437078125c5a92e9a9d5f3bef88949e3c3f3625cc91919091950b8
+-- hash: 25550840a8f69674317309aa4d238d683405902e21b6caa6045ebc08f359593d
name: calamity
-version: 0.1.4.1
+version: 0.1.4.2
synopsis: A library for writing discord bots
description: Please see the README on GitHub at
category: Network, Web
@@ -54,7 +54,7 @@
Calamity.HTTP.Internal.Types
Calamity.HTTP.MiscRoutes
Calamity.Internal.AesonThings
- Calamity.Internal.MessageStore
+ Calamity.Internal.BoundedStore
Calamity.Internal.SnowflakeMap
Calamity.Internal.Updateable
Calamity.Internal.Utils
@@ -77,6 +77,7 @@
Calamity.Types.Model.Channel.Message
Calamity.Types.Model.Channel.Reaction
Calamity.Types.Model.Guild
+ Calamity.Types.Model.Guild.Ban
Calamity.Types.Model.Guild.Emoji
Calamity.Types.Model.Guild.Guild
Calamity.Types.Model.Guild.Invite
@@ -89,6 +90,7 @@
Calamity.Types.Model.Presence.Presence
Calamity.Types.Model.User
Calamity.Types.Model.Voice
+ Calamity.Types.Model.Voice.VoiceRegion
Calamity.Types.Model.Voice.VoiceState
Calamity.Types.Partial
Calamity.Types.Snowflake
diff --git a/src/Calamity/Cache/Eff.hs b/src/Calamity/Cache/Eff.hs
--- a/src/Calamity/Cache/Eff.hs
+++ b/src/Calamity/Cache/Eff.hs
@@ -9,10 +9,12 @@
, setGuild
, updateGuild
, getGuild
+ , getGuilds
, delGuild
, setDM
, updateDM
, getDM
+ , getDMs
, delDM
-- , setGuildChannel
-- , getGuildChannel
@@ -20,13 +22,16 @@
, setUser
, updateUser
, getUser
+ , getUsers
, delUser
, setUnavailableGuild
, isUnavailableGuild
+ , getUnavailableGuilds
, delUnavailableGuild
, setMessage
, updateMessage
, getMessage
+ , getMessages
, delMessage ) where
import Calamity.Internal.Utils
@@ -48,6 +53,8 @@
SetGuild :: Guild -> CacheEff m ()
-- | Get a 'Guild' from the cache
GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild)
+ -- | Get all 'Guild's from the cache
+ GetGuilds :: CacheEff m [Guild]
-- | Delete a 'Guild' from the cache
DelGuild :: Snowflake Guild -> CacheEff m ()
@@ -55,6 +62,8 @@
SetDM :: DMChannel -> CacheEff m ()
-- | Get a 'DMChannel' from the cache
GetDM :: Snowflake DMChannel -> CacheEff m (Maybe DMChannel)
+ -- | Get all 'DM's from the cache
+ GetDMs :: CacheEff m [DMChannel]
-- | Delete a 'DMChannel' from the cache
DelDM :: Snowflake DMChannel -> CacheEff m ()
@@ -68,6 +77,8 @@
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 ()
@@ -75,6 +86,8 @@
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 ()
@@ -82,6 +95,8 @@
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 ()
diff --git a/src/Calamity/Cache/InMemory.hs b/src/Calamity/Cache/InMemory.hs
--- a/src/Calamity/Cache/InMemory.hs
+++ b/src/Calamity/Cache/InMemory.hs
@@ -3,7 +3,7 @@
( runCacheInMemory ) where
import Calamity.Cache.Eff
-import Calamity.Internal.MessageStore
+import Calamity.Internal.BoundedStore
import qualified Calamity.Internal.SnowflakeMap as SM
import Calamity.Internal.Utils
import Calamity.Types.Model.Channel
@@ -15,6 +15,7 @@
import Control.Monad.State.Strict
import Data.Default.Class
+import Data.Foldable
import qualified Data.HashSet as LS
import Data.IORef
@@ -30,7 +31,7 @@
, channels :: SM.SnowflakeMap GuildChannel
, users :: SM.SnowflakeMap User
, unavailableGuilds :: LS.HashSet (Snowflake Guild)
- , messages :: MessageStore
+ , messages :: BoundedStore Message
}
deriving ( Generic, Show )
@@ -40,33 +41,37 @@
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 updateCache' m
-
-updateCache' :: P.Member (P.AtomicState Cache) r => CacheEff m a -> P.Sem r a
-updateCache' act = P.atomicState' ((swap .) . runState $ updateCache act)
+ P.runAtomicStateIORef var $ P.reinterpret runCache' m
-updateCache :: CacheEff m a -> State Cache a
+runCache' :: P.Member (P.AtomicState Cache) r => CacheEff m a -> P.Sem r a
+runCache' act = P.atomicState' ((swap .) . runState $ runCache act)
-updateCache (SetBotUser u) = #user ?= u
-updateCache GetBotUser = use #user
+runCache :: CacheEff m a -> State Cache a
-updateCache (SetGuild g) = #guilds %= SM.insert g
-updateCache (GetGuild gid) = use (#guilds . at gid)
-updateCache (DelGuild gid) = #guilds %= sans gid
+runCache (SetBotUser u) = #user ?= u
+runCache GetBotUser = use #user
+runCache (SetGuild g) = #guilds %= SM.insert g
+runCache (GetGuild gid) = use (#guilds . at gid)
+runCache GetGuilds = SM.elems <$> use #guilds
+runCache (DelGuild gid) = #guilds %= sans gid
-updateCache (SetDM dm) = #dms %= SM.insert dm
-updateCache (GetDM did) = use (#dms . at did)
-updateCache (DelDM did) = #dms %= sans did
+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
-updateCache (SetUser u) = #users %= SM.insert u
-updateCache (GetUser uid) = use (#users . at uid)
-updateCache (DelUser uid) = #users %= sans uid
+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
-updateCache (SetUnavailableGuild gid) = #unavailableGuilds %= LS.insert gid
-updateCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid)
-updateCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid
+runCache (SetUnavailableGuild gid) = #unavailableGuilds %= LS.insert gid
+runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid)
+runCache GetUnavailableGuilds = LS.toList <$> use #unavailableGuilds
+runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid
-updateCache (SetMessage m) = #messages %= addMessage m
-updateCache (GetMessage mid) = use (#messages . at mid)
-updateCache (DelMessage mid) = #messages %= sans mid
+runCache (SetMessage m) = #messages %= addItem m
+runCache (GetMessage mid) = use (#messages . at mid)
+runCache GetMessages = toList <$> use #messages
+runCache (DelMessage mid) = #messages %= sans mid
diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs
--- a/src/Calamity/Client/Client.hs
+++ b/src/Calamity/Client/Client.hs
@@ -11,13 +11,13 @@
import Calamity.Gateway.DispatchEvents
import Calamity.Gateway.Types
import Calamity.HTTP.Internal.Ratelimit
-import qualified Calamity.Internal.SnowflakeMap as SM
+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.UnavailableGuild
-import Calamity.Types.Model.Presence ( Presence(..) )
+import Calamity.Types.Model.Guild
+import Calamity.Types.Model.Presence ( Presence(..) )
import Calamity.Types.Snowflake
import Calamity.Types.Token
@@ -33,20 +33,20 @@
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Traversable
-import qualified Data.TypeRepMap as TM
+import qualified Data.TypeRepMap as TM
-import qualified DiPolysemy as Di
+import qualified DiPolysemy as Di
import Fmt
import GHC.TypeLits
-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 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
timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a)
@@ -219,12 +219,12 @@
updateCache evt
pure $ map (\f -> f oldGuild unavailable) (unwrapEvent @"guilddelete" eh)
-handleEvent' eh evt@(GuildBanAdd GuildBanData { guildID, user }) = do
+handleEvent' eh evt@(GuildBanAdd BanData { guildID, user }) = do
Just guild <- getGuild guildID
updateCache evt
pure $ map (\f -> f guild user) (unwrapEvent @"guildbanadd" eh)
-handleEvent' eh evt@(GuildBanRemove GuildBanData { guildID, user }) = do
+handleEvent' eh evt@(GuildBanRemove BanData { guildID, user }) = do
Just guild <- getGuild guildID
updateCache evt
pure $ map (\f -> f guild user) (unwrapEvent @"guildbanremove" eh)
diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs
--- a/src/Calamity/Client/Types.hs
+++ b/src/Calamity/Client/Types.hs
@@ -41,7 +41,7 @@
import qualified Polysemy.Reader as P
data Client = Client
- { shards :: TVar [(Shard, Async (Maybe ()))] -- TODO: migrate this to a set of Shard (make Shard hash to it's shardThread)
+ { shards :: TVar [(Shard, Async (Maybe ()))]
, numShards :: MVar Int
, token :: Token
, rlState :: RateLimitState
diff --git a/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs
--- a/src/Calamity/Gateway/DispatchEvents.hs
+++ b/src/Calamity/Gateway/DispatchEvents.hs
@@ -5,6 +5,7 @@
import Calamity.Internal.Utils ()
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Channel.Message
+import Calamity.Types.Model.Guild.Ban
import Calamity.Types.Model.Guild.Emoji
import Calamity.Types.Model.Guild.Guild
import Calamity.Types.Model.Guild.Member
@@ -36,8 +37,8 @@
| GuildCreate Guild
| GuildUpdate UpdatedGuild
| GuildDelete UnavailableGuild
- | GuildBanAdd GuildBanData
- | GuildBanRemove GuildBanData
+ | GuildBanAdd BanData
+ | GuildBanRemove BanData
| GuildEmojisUpdate GuildEmojisUpdateData
| GuildIntegrationsUpdate GuildIntegrationsUpdateData
| GuildMemberAdd Member
@@ -77,13 +78,6 @@
}
deriving ( Show, Generic )
deriving FromJSON via CalamityJSON ChannelPinsUpdateData
-
-data GuildBanData = GuildBanData
- { guildID :: Snowflake Guild
- , user :: User
- }
- deriving ( Show, Generic )
- deriving FromJSON via CalamityJSON GuildBanData
data GuildEmojisUpdateData = GuildEmojisUpdateData
{ guildID :: Snowflake Guild
diff --git a/src/Calamity/HTTP/Channel.hs b/src/Calamity/HTTP/Channel.hs
--- a/src/Calamity/HTTP/Channel.hs
+++ b/src/Calamity/HTTP/Channel.hs
@@ -1,8 +1,8 @@
-- | Channel endpoints
module Calamity.HTTP.Channel
- ( ChannelUpdate(..)
+ ( ChannelRequest(..)
+ , ChannelUpdate(..)
, ChannelMessagesQuery(..)
- , ChannelRequest(..)
, GetReactionsOptions(..)
, CreateChannelInviteOptions(..)
, GroupDMAddRecipientOptions(..) ) where
@@ -12,7 +12,6 @@
import Calamity.Internal.AesonThings
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild
-import Calamity.Types.Model.Guild.Overwrite
import Calamity.Types.Model.User
import Calamity.Types.Snowflake
@@ -85,30 +84,30 @@
deriving ( ToJSON ) via CalamityJSON GroupDMAddRecipientOptions
data ChannelRequest a where
- CreateMessage :: (HasID Channel c) => c -> Text -> ChannelRequest Message
- GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message
- EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> Maybe Text -> Maybe Embed -> 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 ChannelMessagesQuery -> 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 ()
+ CreateMessage :: (HasID Channel c) => c -> Text -> ChannelRequest Message
+ GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message
+ EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> Maybe Text -> Maybe Embed -> 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 ChannelMessagesQuery -> 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 _
diff --git a/src/Calamity/HTTP/Emoji.hs b/src/Calamity/HTTP/Emoji.hs
--- a/src/Calamity/HTTP/Emoji.hs
+++ b/src/Calamity/HTTP/Emoji.hs
@@ -36,11 +36,11 @@
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
+ 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 ()
+ 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
diff --git a/src/Calamity/HTTP/Guild.hs b/src/Calamity/HTTP/Guild.hs
--- a/src/Calamity/HTTP/Guild.hs
+++ b/src/Calamity/HTTP/Guild.hs
@@ -2,7 +2,15 @@
module Calamity.HTTP.Guild
( GuildRequest(..)
, CreateGuildData(..)
- , ModifyGuildData(..) ) where
+ , ModifyGuildData(..)
+ , ChannelCreateData(..)
+ , ChannelPosition(..)
+ , ListMembersOptions(..)
+ , AddGuildMemberData(..)
+ , ModifyGuildMemberData(..)
+ , CreateGuildBanData(..)
+ , ModifyGuildRoleData(..)
+ , ModifyGuildRolePositionsData(..) ) where
import Calamity.HTTP.Internal.Request
import Calamity.HTTP.Internal.Route
@@ -10,16 +18,22 @@
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.Arrow
+import Control.Lens hiding ( (.=) )
+
import Data.Aeson
-import Data.Function
+import Data.Maybe
import Data.Text ( Text )
import GHC.Generics
import Network.Wreq
+import TextShow
+
data CreateGuildData = CreateGuildData
{ name :: Text
, region :: Text
@@ -40,20 +54,116 @@
, verificationLevel :: Maybe Integer -- TODO: enums for these
, defaultMessageNotifications :: Maybe Integer
, explicitContentFilter :: Maybe Integer
- , afkChannelID :: Maybe (Snowflake Channel)
+ , afkChannelID :: Maybe (Snowflake GuildChannel)
, afkTimeout :: Maybe Integer
, ownerID :: Maybe (Snowflake User)
, splash :: Maybe Text
, banner :: Maybe Text
- , systemChannelID :: Maybe (Snowflake Channel)
+ , systemChannelID :: Maybe (Snowflake GuildChannel)
}
deriving ( Show, Generic )
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 )
+
+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
+
+data ModifyGuildMemberData = ModifyGuildMemberData
+ { nick :: Maybe Text
+ , roles :: Maybe [Snowflake Role]
+ , mute :: Maybe Bool
+ , deaf :: Maybe Bool
+ , channelID :: Maybe (Snowflake VoiceChannel)
+ }
+ deriving ( Show, Generic )
+ deriving ( ToJSON ) via CalamityJSON ModifyGuildMemberData
+
+data CreateGuildBanData = CreateGuildBanData
+ { deleteMessageDays :: Maybe Integer
+ , reason :: Maybe Text
+ }
+ deriving ( Show, Generic )
+
+data ModifyGuildRoleData = ModifyGuildRoleData
+ { name :: Maybe Text
+ , permissions :: Maybe Integer
+ , color :: Maybe Integer
+ , hoist :: Maybe Bool
+ , mentionable :: Maybe Bool
+ }
+ deriving ( Show, Generic )
+ deriving ( ToJSON ) via CalamityJSON ModifyGuildRoleData
+
+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
+ 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
@@ -66,7 +176,100 @@
& buildRoute
toRoute (ModifyGuild (getID -> gid) _) = baseRoute gid
& buildRoute
+ toRoute (DeleteGuild (getID -> gid)) = baseRoute gid
+ & buildRoute
+ toRoute (GetGuildChannels (getID -> gid)) = baseRoute gid // S "channels"
+ & buildRoute
+ toRoute (CreateGuildChannel (getID -> gid) _) = baseRoute gid // S "channels"
+ & buildRoute
+ toRoute (ModifyGuildChannelPositions (getID -> gid) _) = baseRoute gid // S "channels"
+ & buildRoute
+ toRoute (GetGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (ListGuildMembers (getID -> gid) _) = baseRoute gid // S "members"
+ & buildRoute
+ toRoute (AddGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (ModifyCurrentUserNick (getID -> gid) _) = baseRoute gid // S "members" // S "@me" // S "nick"
+ & buildRoute
+ toRoute (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) =
+ baseRoute gid // S "members" // ID @User // S "roles" // ID @Role
+ & giveID uid
+ & giveID rid
+ & buildRoute
+ toRoute (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) =
+ baseRoute gid // S "members" // ID @User // S "roles" // ID @Role
+ & giveID uid
+ & giveID rid
+ & buildRoute
+ toRoute (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (GetGuildBans (getID -> gid)) = baseRoute gid // S "bans"
+ & buildRoute
+ toRoute (GetGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (CreateGuildBan (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "bans" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User
+ & giveID uid
+ & buildRoute
+ toRoute (GetGuildRoles (getID -> gid)) = baseRoute gid // S "roles"
+ & buildRoute
+ toRoute (CreateGuildRole (getID -> gid) _) = baseRoute gid // S "roles"
+ & buildRoute
+ toRoute (ModifyGuildRolePositions (getID -> gid) _) = baseRoute gid // S "roles"
+ & buildRoute
+ toRoute (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = baseRoute gid // S "roles" // ID @Role
+ & giveID rid
+ & buildRoute
+ toRoute (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = baseRoute gid // S "roles" // ID @Role
+ & giveID rid
+ & buildRoute
+ toRoute (GetGuildPruneCount (getID -> gid) _) = baseRoute gid // S "prune"
+ & buildRoute
+ toRoute (BeginGuildPrune (getID -> gid) _ _) = baseRoute gid // S "prune"
+ & buildRoute
+ toRoute (GetGuildVoiceRegions (getID -> gid)) = baseRoute gid // S "regions"
+ & buildRoute
+ toRoute (GetGuildInvites (getID -> gid)) = baseRoute gid // S "invites"
+ & buildRoute
toAction (CreateGuild o) = postWith' (toJSON o)
toAction (GetGuild _) = getWith
toAction (ModifyGuild _ o) = patchWith' (toJSON o)
+ toAction (DeleteGuild _) = deleteWith
+ toAction (GetGuildChannels _) = getWith
+ toAction (CreateGuildChannel _ o) = postWith' (toJSON o)
+ toAction (ModifyGuildChannelPositions _ o) = postWith' (toJSON o)
+ toAction (GetGuildMember _ _) = getWith
+ toAction (ListGuildMembers _ ListMembersOptions { limit, after }) = getWithP
+ (param "limit" .~ maybeToList (showt <$> limit) >>> param "after" .~ maybeToList (showt <$> after))
+ toAction (AddGuildMember _ _ o) = putWith' (toJSON o)
+ toAction (ModifyGuildMember _ _ o) = patchWith' (toJSON o)
+ toAction (ModifyCurrentUserNick _ nick) = patchWith' (object ["nick" .= nick])
+ toAction (AddGuildMemberRole {}) = putEmpty
+ toAction (RemoveGuildMemberRole {}) = deleteWith
+ toAction (RemoveGuildMember _ _) = deleteWith
+ toAction (GetGuildBans _) = getWith
+ toAction (GetGuildBan _ _) = getWith
+ toAction (CreateGuildBan _ _ CreateGuildBanData { deleteMessageDays, reason }) = putEmptyP
+ (param "delete-message-days" .~ maybeToList (showt <$> deleteMessageDays) >>> param "reason" .~ maybeToList
+ (showt <$> reason))
+ toAction (RemoveGuildBan _ _) = deleteWith
+ toAction (GetGuildRoles _) = getWith
+ toAction (CreateGuildRole _ o) = postWith' (toJSON o)
+ toAction (ModifyGuildRolePositions _ o) = patchWith' (toJSON o)
+ toAction (ModifyGuildRole _ _ o) = patchWith' (toJSON o)
+ toAction (DeleteGuildRole _ _) = deleteWith
+ toAction (GetGuildPruneCount _ d) = getWithP (param "days" .~ [showt d])
+ toAction (BeginGuildPrune _ d r) = postEmptyP (param "days" .~ [showt d] >>> param "compute_prune_count" .~ [showt r])
+ toAction (GetGuildVoiceRegions _) = getWith
+ toAction (GetGuildInvites _) = getWith
diff --git a/src/Calamity/HTTP/Internal/Request.hs b/src/Calamity/HTTP/Internal/Request.hs
--- a/src/Calamity/HTTP/Internal/Request.hs
+++ b/src/Calamity/HTTP/Internal/Request.hs
@@ -5,7 +5,9 @@
, putWith'
, patchWith'
, putEmpty
+ , putEmptyP
, postEmpty
+ , postEmptyP
, getWithP ) where
import Calamity.Client.Types
@@ -115,6 +117,12 @@
putEmpty :: Options -> String -> IO (Response LB.ByteString)
putEmpty o s = putWith o s ("" :: ByteString)
+
+putEmptyP :: (Options -> Options) -> Options -> String -> IO (Response LB.ByteString)
+putEmptyP = (putEmpty .)
+
+postEmptyP :: (Options -> Options) -> Options -> String -> IO (Response LB.ByteString)
+postEmptyP = (postEmpty .)
getWithP :: (Options -> Options) -> Options -> String -> IO (Response LB.ByteString)
getWithP oF o = getWith (oF o)
diff --git a/src/Calamity/HTTP/Internal/Route.hs b/src/Calamity/HTTP/Internal/Route.hs
--- a/src/Calamity/HTTP/Internal/Route.hs
+++ b/src/Calamity/HTTP/Internal/Route.hs
@@ -19,7 +19,6 @@
import Data.Hashable
import Data.Kind
-import Data.List ( lookup )
import Data.Maybe ( fromJust )
import Data.Text ( Text )
import qualified Data.Text as T
diff --git a/src/Calamity/HTTP/MiscRoutes.hs b/src/Calamity/HTTP/MiscRoutes.hs
--- a/src/Calamity/HTTP/MiscRoutes.hs
+++ b/src/Calamity/HTTP/MiscRoutes.hs
@@ -10,7 +10,7 @@
import Network.Wreq
data MiscRequest a where
- GetGateway :: MiscRequest GatewayResponse
+ GetGateway :: MiscRequest GatewayResponse
GetGatewayBot :: MiscRequest BotGatewayResponse
instance Request (MiscRequest a) a where
diff --git a/src/Calamity/Internal/BoundedStore.hs b/src/Calamity/Internal/BoundedStore.hs
new file mode 100644
--- /dev/null
+++ b/src/Calamity/Internal/BoundedStore.hs
@@ -0,0 +1,85 @@
+-- | A thing for storing the last N things with IDs
+module Calamity.Internal.BoundedStore
+ ( BoundedStore(..)
+ , 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.Lazy ( HashMap )
+import qualified Data.HashMap.Lazy as H
+
+import qualified Deque.Lazy as DQ
+import Deque.Lazy ( Deque )
+
+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 H.empty 1000 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 #-}
diff --git a/src/Calamity/Internal/MessageStore.hs b/src/Calamity/Internal/MessageStore.hs
deleted file mode 100644
--- a/src/Calamity/Internal/MessageStore.hs
+++ /dev/null
@@ -1,84 +0,0 @@
--- | A thing for storing the last N messages
-module Calamity.Internal.MessageStore
- ( MessageStore(..)
- , addMessage
- , getMessage
- , dropMessage ) where
-
-import Calamity.Internal.Utils
-import Calamity.Types.Model.Channel.Message
-import Calamity.Types.Snowflake
-
-import Control.Lens
-import Control.Lens.Operators ( (.=) )
-import Control.Monad.State.Lazy
-
-import Data.Default.Class
-import Data.Generics.Labels ()
-import Data.HashMap.Lazy ( HashMap )
-import qualified Data.HashMap.Lazy as H
-
-import qualified Deque.Lazy as DQ
-import Deque.Lazy ( Deque )
-
-import GHC.Generics
-
-data MessageStore = MessageStore
- { messageQueue :: Deque (Snowflake Message)
- , messages :: HashMap (Snowflake Message) Message
- , limit :: Int
- , size :: Int
- }
- deriving ( Show, Generic )
-
-instance Default MessageStore where
- def = MessageStore mempty H.empty 1000 0
-
-type instance (Index MessageStore) = Snowflake Message
-type instance (IxValue MessageStore) = Message
-
-instance Ixed MessageStore
-
-instance At MessageStore where
- at k f m = f mv <&> \case
- Nothing -> maybe m (const (dropMessage k m)) mv
- Just v -> addMessage v m
- where
- mv = getMessage k m
-
- {-# INLINE at #-}
-
-addMessage :: Message -> MessageStore -> MessageStore
-addMessage m = execState $ do
- unlessM (H.member (m ^. #id) <$> use #messages) do
- #messageQueue %= DQ.cons (getID m)
- #size += 1
-
- size <- use #size
- limit <- use #limit
-
- when (size > limit) do
- q <- use #messageQueue
- let Just (rid, q') = DQ.unsnoc q
- #messageQueue .= q'
- #messages %= sans rid
- #size -= 1
-
- #messages %= H.insert (getID m) m
-
-{-# INLINE addMessage #-}
-
-getMessage :: Snowflake Message -> MessageStore -> Maybe Message
-getMessage id s = H.lookup id (s ^. #messages)
-
-{-# INLINE getMessage #-}
-
-dropMessage :: Snowflake Message -> MessageStore -> MessageStore
-dropMessage id = execState $ do
- whenM (H.member id <$> use #messages) do
- #size -= 1
-
- #messageQueue %= DQ.filter (/= id)
- #messages %= H.delete id
-
-{-# INLINE dropMessage #-}
diff --git a/src/Calamity/Internal/SnowflakeMap.hs b/src/Calamity/Internal/SnowflakeMap.hs
--- a/src/Calamity/Internal/SnowflakeMap.hs
+++ b/src/Calamity/Internal/SnowflakeMap.hs
@@ -69,7 +69,7 @@
over f = SnowflakeMap . f . unSnowflakeMap
{-# INLINABLE over #-}
--- I guess I could just do this by unwrapping everything and using coerceSnowflake
+-- SAFETY: 'Snowflake' always uses the underlying hash function (Word64)
coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v
coerceSnowflakeMap = unsafeCoerce
{-# INLINABLE coerceSnowflakeMap #-}
diff --git a/src/Calamity/Types/Model/Channel.hs b/src/Calamity/Types/Model/Channel.hs
--- a/src/Calamity/Types/Model/Channel.hs
+++ b/src/Calamity/Types/Model/Channel.hs
@@ -55,9 +55,10 @@
GroupDMType -> GroupChannel' <$> parseJSON (Object v)
data instance Partial Channel = PartialChannel
- { id :: Snowflake Channel
- , name :: Text
- , type_ :: ChannelType
+ { id :: Snowflake Channel
+ , name :: Text
+ , type_ :: ChannelType
+ , parentID :: Maybe (Snowflake Category)
}
deriving ( Show, Eq, Generic )
deriving ( TextShow ) via TSG.FromGeneric (Partial Channel)
diff --git a/src/Calamity/Types/Model/Guild.hs b/src/Calamity/Types/Model/Guild.hs
--- a/src/Calamity/Types/Model/Guild.hs
+++ b/src/Calamity/Types/Model/Guild.hs
@@ -1,6 +1,7 @@
-- | Discord Guilds
module Calamity.Types.Model.Guild
- ( module Calamity.Types.Model.Guild.Emoji
+ ( module Calamity.Types.Model.Guild.Ban
+ , module Calamity.Types.Model.Guild.Emoji
, module Calamity.Types.Model.Guild.Guild
, module Calamity.Types.Model.Guild.Member
, module Calamity.Types.Model.Guild.Overwrite
@@ -8,6 +9,7 @@
, module Calamity.Types.Model.Guild.Role
, module Calamity.Types.Model.Guild.UnavailableGuild ) where
+import Calamity.Types.Model.Guild.Ban
import Calamity.Types.Model.Guild.Emoji
import Calamity.Types.Model.Guild.Guild hiding ( UpdatedGuild(..) )
import Calamity.Types.Model.Guild.Invite
diff --git a/src/Calamity/Types/Model/Guild/Ban.hs b/src/Calamity/Types/Model/Guild/Ban.hs
new file mode 100644
--- /dev/null
+++ b/src/Calamity/Types/Model/Guild/Ban.hs
@@ -0,0 +1,26 @@
+-- | Guild ban objects
+module Calamity.Types.Model.Guild.Ban
+ ( BanData(..) ) where
+
+import Calamity.Internal.AesonThings
+import Calamity.Internal.Utils ()
+import Calamity.Types.Model.Guild.Guild
+import Calamity.Types.Model.User
+import Calamity.Types.Snowflake
+
+import Data.Aeson
+
+import GHC.Generics
+
+import TextShow
+import qualified TextShow.Generic as TSG
+
+data BanData = BanData
+ { guildID :: Snowflake Guild
+ , user :: User
+ }
+ deriving ( Show, Generic )
+ deriving ( FromJSON ) via CalamityJSON BanData
+ deriving ( TextShow ) via TSG.FromGeneric BanData
+ deriving ( HasID Guild ) via HasIDField "guildID" BanData
+ deriving ( HasID User ) via HasIDField "user" BanData
diff --git a/src/Calamity/Types/Model/Voice.hs b/src/Calamity/Types/Model/Voice.hs
--- a/src/Calamity/Types/Model/Voice.hs
+++ b/src/Calamity/Types/Model/Voice.hs
@@ -1,5 +1,7 @@
-- | Voice data types
module Calamity.Types.Model.Voice
- ( module Calamity.Types.Model.Voice.VoiceState ) where
+ ( module Calamity.Types.Model.Voice.VoiceState
+ , module Calamity.Types.Model.Voice.VoiceRegion ) where
+import Calamity.Types.Model.Voice.VoiceRegion
import Calamity.Types.Model.Voice.VoiceState
diff --git a/src/Calamity/Types/Model/Voice/VoiceRegion.hs b/src/Calamity/Types/Model/Voice/VoiceRegion.hs
new file mode 100644
--- /dev/null
+++ b/src/Calamity/Types/Model/Voice/VoiceRegion.hs
@@ -0,0 +1,26 @@
+-- | Voice regions
+module Calamity.Types.Model.Voice.VoiceRegion
+ ( VoiceRegion(..) ) where
+
+import Calamity.Internal.AesonThings
+import Calamity.Types.Snowflake
+
+import Data.Aeson
+import Data.Text.Lazy ( Text )
+
+import GHC.Generics
+
+import TextShow
+import qualified TextShow.Generic as TSG
+
+data VoiceRegion = VoiceRegion
+ { id :: Snowflake VoiceRegion
+ , name :: Text
+ , vip :: Bool
+ , optimal :: Bool
+ , deprecated :: Bool
+ , custom :: Bool
+ }
+ deriving ( Show, Eq, Generic )
+ deriving ( TextShow ) via TSG.FromGeneric VoiceRegion
+ deriving ( ToJSON, FromJSON ) via CalamityJSON VoiceRegion
diff --git a/src/Calamity/Types/Snowflake.hs b/src/Calamity/Types/Snowflake.hs
--- a/src/Calamity/Types/Snowflake.hs
+++ b/src/Calamity/Types/Snowflake.hs
@@ -60,8 +60,8 @@
-- | A newtype wrapper for deriving HasID generically
newtype HasIDField field a = HasIDField a
-instance HasField' field a (Snowflake b) => HasID b (HasIDField field a) where
- getID (HasIDField a) = a ^. field' @field
+instance (HasID b c, HasField' field a c) => HasID b (HasIDField field a) where
+ getID (HasIDField a) = getID $ a ^. field' @field
-- | A data `a` which contains an ID of type `Snowflake c`
-- which should be swapped with `Snowflake b` upon fetching
@@ -69,8 +69,8 @@
type HasIDFieldCoerce' field a = HasIDFieldCoerce field a a
-instance HasField' field a (Snowflake c) => HasID b (HasIDFieldCoerce field a c) where
- getID (HasIDFieldCoerce a) = coerceSnowflake $ a ^. field' @field
+instance (HasID c d, HasField' field a d) => HasID b (HasIDFieldCoerce field a c) where
+ getID (HasIDFieldCoerce a) = coerceSnowflake . getID @c $ a ^. field' @field
instance HasID a (Snowflake a) where
getID = id