diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 25550840a8f69674317309aa4d238d683405902e21b6caa6045ebc08f359593d +-- hash: be510d66d49f55eee979f88e81ccd03d77fc73990d6f0cbc83c7242e64ddeec7 name: calamity -version: 0.1.4.2 +version: 0.1.4.3 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -52,7 +52,9 @@ Calamity.HTTP.Internal.Request Calamity.HTTP.Internal.Route Calamity.HTTP.Internal.Types + Calamity.HTTP.Invite Calamity.HTTP.MiscRoutes + Calamity.HTTP.User Calamity.Internal.AesonThings Calamity.Internal.BoundedStore Calamity.Internal.SnowflakeMap @@ -76,6 +78,7 @@ Calamity.Types.Model.Channel.Guild.Voice Calamity.Types.Model.Channel.Message Calamity.Types.Model.Channel.Reaction + Calamity.Types.Model.Channel.Webhook Calamity.Types.Model.Guild Calamity.Types.Model.Guild.Ban Calamity.Types.Model.Guild.Emoji 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 @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + -- | The client module Calamity.Client.Client ( Client(..) @@ -30,7 +32,6 @@ import Data.Dynamic import Data.Foldable import Data.Maybe -import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Traversable import qualified Data.TypeRepMap as TM @@ -156,7 +157,7 @@ => EventHandlers -> DispatchData -> P.Sem (P.Fail ': r) [P.Sem r ()] -handleEvent' eh evt@(Ready rd@ReadyData { user, guilds }) = do +handleEvent' eh evt@(Ready rd@ReadyData {}) = do updateCache evt pure $ map ($ rd) (unwrapEvent @"ready" eh) @@ -400,7 +401,7 @@ updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles, user, nick }) = do setUser user - updateGuild guildID (#members . at (getID user) . _Just %~ (#roles .~ roles) . (#nick .~ nick)) + updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) updateCache (GuildMembersChunk GuildMembersChunkData { members }) = traverse_ (updateCache . GuildMemberAdd) members @@ -439,4 +440,19 @@ updateCache (UserUpdate user) = setBotUser user -updateCache _data' = pure () -- TODO +-- 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 () + +-- we don't handle voice state currently +updateCache (VoiceStateUpdate _) = pure () +updateCache (VoiceServerUpdate _) = pure () diff --git a/src/Calamity/HTTP.hs b/src/Calamity/HTTP.hs --- a/src/Calamity/HTTP.hs +++ b/src/Calamity/HTTP.hs @@ -4,10 +4,14 @@ , module Calamity.HTTP.Channel , module Calamity.HTTP.Emoji , module Calamity.HTTP.Guild - , module Calamity.HTTP.MiscRoutes ) where + , module Calamity.HTTP.Invite + , module Calamity.HTTP.MiscRoutes + , module Calamity.HTTP.User ) where import Calamity.HTTP.Channel import Calamity.HTTP.Emoji import Calamity.HTTP.Guild import Calamity.HTTP.Internal.Request ( invokeRequest ) +import Calamity.HTTP.Invite import Calamity.HTTP.MiscRoutes +import Calamity.HTTP.User 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 @@ -40,8 +40,7 @@ , permissionOverwrites :: Maybe [Overwrite] , parentID :: Maybe (Snowflake Channel) } - deriving ( Generic, Show ) - deriving anyclass ( Default ) + deriving ( Generic, Show, Default ) deriving ( ToJSON ) via CalamityJSON ChannelUpdate data ChannelMessagesQuery @@ -65,7 +64,7 @@ , after :: Maybe (Snowflake User) , limit :: Maybe Integer } - deriving ( Show ) + deriving ( Show, Generic, Default ) data CreateChannelInviteOptions = CreateChannelInviteOptions { maxAge :: Maybe Int @@ -73,7 +72,7 @@ , temporary :: Maybe Bool , unique :: Maybe Bool } - deriving ( Show, Generic ) + deriving ( Show, Generic, Default ) deriving ( ToJSON ) via CalamityJSON CreateChannelInviteOptions data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions 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 @@ -25,6 +25,7 @@ import Control.Lens hiding ( (.=) ) import Data.Aeson +import Data.Default.Class import Data.Maybe import Data.Text ( Text ) @@ -61,7 +62,7 @@ , banner :: Maybe Text , systemChannelID :: Maybe (Snowflake GuildChannel) } - deriving ( Show, Generic ) + deriving ( Show, Generic, Default ) deriving ( ToJSON ) via CalamityJSON ModifyGuildData data ChannelCreateData = ChannelCreateData @@ -90,7 +91,7 @@ { limit :: Maybe Integer , after :: Maybe (Snowflake User) } - deriving ( Show, Generic ) + deriving ( Show, Generic, Default ) data AddGuildMemberData = AddGuildMemberData { accessToken :: Text @@ -109,14 +110,14 @@ , deaf :: Maybe Bool , channelID :: Maybe (Snowflake VoiceChannel) } - deriving ( Show, Generic ) + deriving ( Show, Generic, Default ) deriving ( ToJSON ) via CalamityJSON ModifyGuildMemberData data CreateGuildBanData = CreateGuildBanData { deleteMessageDays :: Maybe Integer , reason :: Maybe Text } - deriving ( Show, Generic ) + deriving ( Show, Generic, Default ) data ModifyGuildRoleData = ModifyGuildRoleData { name :: Maybe Text @@ -125,7 +126,7 @@ , hoist :: Maybe Bool , mentionable :: Maybe Bool } - deriving ( Show, Generic ) + deriving ( Show, Generic, Default ) deriving ( ToJSON ) via CalamityJSON ModifyGuildRoleData data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData diff --git a/src/Calamity/HTTP/Invite.hs b/src/Calamity/HTTP/Invite.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Invite.hs @@ -0,0 +1,31 @@ +-- | 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.Wreq + +import TextShow + +data InviteRequest a where + GetInvite :: Text -> InviteRequest Invite + DeleteInvite :: Text -> InviteRequest () + +baseRoute :: RouteBuilder _ +baseRoute = mkRouteBuilder // S "invites" + +instance Request (InviteRequest a) a where + toRoute (GetInvite c) = baseRoute // S c + & buildRoute + toRoute (DeleteInvite c) = baseRoute // S c + & buildRoute + + toAction (GetInvite _) = getWithP (param "with_counts" .~ [showt True]) + toAction (DeleteInvite _) = deleteWith diff --git a/src/Calamity/HTTP/User.hs b/src/Calamity/HTTP/User.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/User.hs @@ -0,0 +1,78 @@ +-- | 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.Arrow +import Control.Lens hiding ( (.=) ) + +import Data.Aeson +import Data.Default.Class +import Data.Maybe +import Data.Text ( Text ) + +import GHC.Generics + +import Network.Wreq + +import TextShow + +data ModifyUserData = ModifyUserData + { username :: Maybe Text + -- | The avatar field should be in discord's image data format: https://discordapp.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) a where + toRoute GetCurrentUser = baseRoute + & buildRoute + toRoute (GetUser (getID @User -> uid)) = mkRouteBuilder // S "users" // ID @User + & giveID uid + & buildRoute + toRoute (ModifyCurrentUser _) = baseRoute + & buildRoute + toRoute (GetCurrentUserGuilds _) = baseRoute // S "guilds" + & buildRoute + toRoute (LeaveGuild (getID @Guild -> gid)) = baseRoute // S "guilds" // ID @Guild + & giveID gid + & buildRoute + toRoute (CreateDM _) = baseRoute // S "channels" + & buildRoute + + toAction GetCurrentUser = getWith + toAction (GetUser _) = getWith + toAction (ModifyCurrentUser o) = patchWith' (toJSON o) + toAction (GetCurrentUserGuilds GetCurrentUserGuildsOptions { before, after, limit }) = getWithP + (param "before" .~ maybeToList (showt <$> before) >>> param "after" .~ maybeToList (showt <$> after) >>> param + "limit" .~ maybeToList (showt <$> limit)) + toAction (LeaveGuild _) = deleteWith + toAction (CreateDM (getID @User -> uid)) = postWith' (object ["recipient_id" .= uid]) 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 @@ -7,6 +7,7 @@ , 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 @@ -20,6 +21,7 @@ import Calamity.Types.Model.Channel.Guild import {-# SOURCE #-} Calamity.Types.Model.Channel.Message hiding ( UpdatedMessage ) import Calamity.Types.Model.Channel.Reaction +import Calamity.Types.Model.Channel.Webhook import Calamity.Types.Partial import Calamity.Types.Snowflake diff --git a/src/Calamity/Types/Model/Channel/Webhook.hs b/src/Calamity/Types/Model/Channel/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Webhook.hs @@ -0,0 +1,32 @@ +-- | Channel webhooks +module Calamity.Types.Model.Channel.Webhook + ( Webhook(..) ) where + +import Calamity.Internal.AesonThings +import {-# SOURCE #-} Calamity.Types.Model.Channel +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake + +import Data.Aeson +import Data.Text.Lazy ( Text ) + +import GHC.Generics + +import TextShow +import qualified TextShow.Generic as TSG + +data Webhook = Webhook + { id :: Snowflake Webhook + , type_ :: Integer + , guildID :: Maybe (Snowflake Guild) + , channelID :: Maybe (Snowflake Channel) + , user :: Maybe (Snowflake User) + , name :: Text + , avatar :: Text + , token :: Maybe Text + } + deriving ( Eq, Show, Generic ) + deriving ( TextShow ) via TSG.FromGeneric Webhook + deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractField` "id"] Webhook + deriving ( HasID Webhook ) via HasIDField "id" Webhook