diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -104,27 +104,29 @@ info = DiP.info @Text debug = DiP.info @Text +tellt = tell @Text + main :: IO () main = do - P.runFinal . P.embedToFinal . handleFailByPrinting . runCounterAtomic . runCacheInMemory . runMetricsNoop $ runBotIO - (BotToken "") $ do - react @"messagecreate" $ \msg -> handleFailByLogging $ do - when (msg ^. #content == "!count") $ replicateM_ 3 $ do - val <- getCounter - info $ "the counter is: " <> fromStrict (showt val) - void . invokeRequest $ CreateMessage (msg ^. #channelID) ("The value is: " <> showt val) - when (msg ^. #content == "!say hi") $ replicateM_ 3 . P.async $ do - info "saying heya" - Right msg' <- invokeRequest $ CreateMessage (msg ^. #channelID) "heya" - info "sleeping" - P.embed $ threadDelay (5 * 1000 * 1000) - info "slept" - void . invokeRequest $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing - info "edited" - when (msg ^. #content == "!explode") $ do - Just x <- pure Nothing - debug "unreachable!" - when (msg ^. #content == "!bye") $ do - void . invokeRequest $ CreateMessage (msg ^. #channelID) "bye!" - stopBot + token <- view packed <$> getEnv "BOT_TOKEN" + P.runFinal . P.embedToFinal . handleFailByPrinting . runCounterAtomic . runCacheInMemory . runMetricsNoop + $ runBotIO (BotToken token) $ react @"messagecreate" $ \msg -> handleFailByLogging $ do + when (msg ^. #content == "!count") $ replicateM_ 3 $ do + val <- getCounter + info $ "the counter is: " <> showt val + void $ tellt msg ("The value is: " <> showt val) + when (msg ^. #content == "!say hi") $ replicateM_ 3 . P.async $ do + info "saying heya" + Right msg' <- tellt msg "heya" + info "sleeping" + P.embed $ threadDelay (5 * 1000 * 1000) + info "slept" + void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing + info "edited" + when (msg ^. #content == "!explode") $ do + Just x <- pure Nothing + debug "unreachable!" + when (msg ^. #content == "!bye") $ do + void $ tellt msg "bye!" + stopBot ``` 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: 5c7efe15b2591781800d2351bc951927dd700e2f79d18d28ae979dc7dfe58f0b +-- hash: cd2b6837ac1a0aafe0608b377821ae47dba465830404b42d9bfc1c20a5db9ac6 name: calamity -version: 0.1.4.4 +version: 0.1.5.0 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -45,6 +45,7 @@ Calamity.Gateway.Shard Calamity.Gateway.Types Calamity.HTTP + Calamity.HTTP.AuditLog Calamity.HTTP.Channel Calamity.HTTP.Emoji Calamity.HTTP.Guild @@ -54,6 +55,7 @@ Calamity.HTTP.Internal.Types Calamity.HTTP.Invite Calamity.HTTP.MiscRoutes + Calamity.HTTP.Reason Calamity.HTTP.User Calamity.HTTP.Webhook Calamity.Internal.AesonThings @@ -81,6 +83,7 @@ Calamity.Types.Model.Channel.Reaction Calamity.Types.Model.Channel.Webhook Calamity.Types.Model.Guild + Calamity.Types.Model.Guild.AuditLog Calamity.Types.Model.Guild.Ban Calamity.Types.Model.Guild.Emoji Calamity.Types.Model.Guild.Guild @@ -98,6 +101,7 @@ Calamity.Types.Model.Voice.VoiceState Calamity.Types.Partial Calamity.Types.Snowflake + Calamity.Types.Tellable Calamity.Types.Token Calamity.Types.UnixTimestamp other-modules: diff --git a/src/Calamity/Client/ShardManager.hs b/src/Calamity/Client/ShardManager.hs --- a/src/Calamity/Client/ShardManager.hs +++ b/src/Calamity/Client/ShardManager.hs @@ -33,7 +33,7 @@ token <- P.asks Calamity.Client.Types.token eventQueue <- P.asks eventQueue - Right gateway <- invokeRequest GetGatewayBot + Right gateway <- invoke GetGatewayBot let numShards' = gateway ^. #shards let host = gateway ^. #url @@ -59,7 +59,7 @@ -- eventQueue <- asks eventQueue -- logEnv <- askLog --- gateway <- aa <$> invokeRequest GetGateway +-- gateway <- aa <$> invoke GetGateway -- let host = gateway ^. #url -- liftIO $ putMVar numShardsVar 1 diff --git a/src/Calamity/Gateway/Types.hs b/src/Calamity/Gateway/Types.hs --- a/src/Calamity/Gateway/Types.hs +++ b/src/Calamity/Gateway/Types.hs @@ -113,6 +113,18 @@ 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') diff --git a/src/Calamity/HTTP.hs b/src/Calamity/HTTP.hs --- a/src/Calamity/HTTP.hs +++ b/src/Calamity/HTTP.hs @@ -1,19 +1,25 @@ -- | Combined http request stuff module Calamity.HTTP - ( module Calamity.HTTP.Internal.Request + ( module Calamity.HTTP.AuditLog + , module Calamity.HTTP.Internal.Request , 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 ) where +import Calamity.HTTP.AuditLog import Calamity.HTTP.Channel import Calamity.HTTP.Emoji import Calamity.HTTP.Guild -import Calamity.HTTP.Internal.Request ( invokeRequest ) +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 diff --git a/src/Calamity/HTTP/AuditLog.hs b/src/Calamity/HTTP/AuditLog.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/AuditLog.hs @@ -0,0 +1,41 @@ +-- | Audit Log endpoints +module Calamity.HTTP.AuditLog + ( AuditLogRequest(..) + , GetAuditLogOptions(..) ) 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.Model.User +import Calamity.Types.Snowflake + +import Data.Aeson +import Data.Default.Class +import Data.Function + +import GHC.Generics + +import Network.Wreq + +data GetAuditLogOptions = GetAuditLogOptions + { userID :: Maybe (Snowflake User) + , actionType :: Maybe AuditLogAction + , before :: Maybe (Snowflake AuditLogEntry) + , limit :: Maybe Integer + } + deriving ( Show, Generic, Default ) + deriving ( ToJSON ) via CalamityJSON GetAuditLogOptions + +data AuditLogRequest a where + GetAuditLog :: HasID Guild g => g -> 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 _) = getWith 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,6 +1,7 @@ -- | Channel endpoints module Calamity.HTTP.Channel ( ChannelRequest(..) + , CreateMessageOptions(..) , ChannelUpdate(..) , ChannelMessagesQuery(..) , GetReactionsOptions(..) @@ -16,12 +17,14 @@ import Calamity.Types.Snowflake import Control.Arrow -import Control.Lens hiding ( (.=) ) +import Control.Lens hiding ( (.=) ) import Data.Aeson +import Data.ByteString.Lazy ( ByteString ) import Data.Default.Class +import Data.Generics.Product.Subtype ( upcast ) import Data.Maybe -import Data.Text ( Text ) +import Data.Text ( Text ) import GHC.Generics @@ -29,6 +32,24 @@ import TextShow +data CreateMessageOptions = CreateMessageOptions + { content :: Maybe Text + , nonce :: Maybe Text + , tts :: Maybe Bool + , file :: Maybe ByteString + , embed :: Maybe Embed + } + deriving ( Show, Generic, Default ) + +data CreateMessageJson = CreateMessageJson + { content :: Maybe Text + , nonce :: Maybe Text + , tts :: Maybe Bool + , embed :: Maybe Embed + } + deriving ( Show, Generic ) + deriving ( ToJSON ) via CalamityJSON CreateMessageJson + data ChannelUpdate = ChannelUpdate { name :: Maybe Text , position :: Maybe Int @@ -83,7 +104,7 @@ deriving ( ToJSON ) via CalamityJSON GroupDMAddRecipientOptions data ChannelRequest a where - CreateMessage :: (HasID Channel c) => c -> Text -> ChannelRequest Message + 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 -> Maybe Text -> Maybe Embed -> ChannelRequest Message DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () @@ -113,101 +134,113 @@ baseRoute id = mkRouteBuilder // S "channels" // ID @Channel & giveID id -instance Request (ChannelRequest a) a where - toRoute (CreateMessage (getID -> id) _) = baseRoute id // S "messages" & buildRoute - toRoute (GetChannel (getID -> id)) = baseRoute id & buildRoute - toRoute (ModifyChannel (getID -> id) _) = baseRoute id & buildRoute - toRoute (DeleteChannel (getID -> id)) = baseRoute id & buildRoute - toRoute (GetChannelMessages (getID -> id) _) = baseRoute id // S "messages" & buildRoute - toRoute (GetMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message +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 - toRoute (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = + route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me" & giveID mid & buildRoute - toRoute (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = + route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me" & giveID mid & buildRoute - toRoute (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = + 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 - toRoute (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = + route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) & giveID mid & buildRoute - toRoute (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = + route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message // S "reactions" & giveID mid & buildRoute - toRoute (EditMessage (getID -> cid) (getID @Message -> mid) _ _) = - baseRoute cid // S "messages" // ID @Message + route (EditMessage (getID -> cid) (getID @Message -> mid) _ _) = baseRoute cid // S "messages" // ID @Message & giveID mid & buildRoute - toRoute (DeleteMessage (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "messages" // ID @Message + route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message & giveID mid & buildRoute - toRoute (BulkDeleteMessages (getID -> cid) _) = - baseRoute cid // S "messages" // S "bulk-delete" + route (BulkDeleteMessages (getID -> cid) _) = baseRoute cid // S "messages" // S "bulk-delete" & buildRoute - toRoute (GetChannelInvites (getID -> cid)) = baseRoute cid // S "invites" & buildRoute - toRoute (CreateChannelInvite (getID -> cid) _) = baseRoute cid // S "invites" & buildRoute - toRoute (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) = + 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 - toRoute (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = + route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = baseRoute cid // S "permissions" // ID @Overwrite & giveID oid & buildRoute - toRoute (TriggerTyping (getID -> cid)) = baseRoute cid // S "typing" & buildRoute - toRoute (GetPinnedMessages (getID -> cid)) = baseRoute cid // S "pins" & buildRoute - toRoute (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message + 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 - toRoute (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message + route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message & giveID mid & buildRoute - toRoute (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = baseRoute cid // S "recipients" // ID @User + route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = baseRoute cid // S "recipients" // ID @User & giveID uid & buildRoute - toRoute (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = baseRoute cid // S "recipients" // ID @User + route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = baseRoute cid // S "recipients" // ID @User & giveID uid & buildRoute - toAction (CreateMessage _ t) = postWith' (object ["content" .= t]) - toAction (GetChannel _) = getWith - toAction (ModifyChannel _ p) = putWith' (toJSON p) - toAction (DeleteChannel _) = deleteWith - toAction (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a)))) = getWithP (param "around" .~ [a]) - toAction (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a)))) = getWithP (param "before" .~ [a]) - toAction (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a)))) = getWithP (param "after" .~ [a]) - toAction (GetChannelMessages _ (Just (ChannelMessagesLimit (showt -> a)))) = getWithP (param "around" .~ [a]) - toAction (GetChannelMessages _ Nothing) = getWith - toAction (GetMessage _ _) = getWith - toAction CreateReaction {} = putEmpty - toAction DeleteOwnReaction {} = deleteWith - toAction DeleteUserReaction {} = deleteWith - toAction (GetReactions _ _ _ GetReactionsOptions { before, after, limit }) = getWithP - (param "before" .~ maybeToList (showt <$> before) - >>> param "after" .~ maybeToList (showt <$> after) - >>> param "limit" .~ maybeToList (showt <$> limit)) - toAction (DeleteAllReactions _ _) = deleteWith - toAction (EditMessage _ _ content embed) = patchWith' - (object ["content" .= content, "embed" .= embed]) - toAction (DeleteMessage _ _) = deleteWith - toAction (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (object ["messages" .= ids]) - toAction (GetChannelInvites _) = getWith - toAction (CreateChannelInvite _ o) = postWith' (toJSON o) - toAction (EditChannelPermissions _ o) = putWith' (toJSON o) - toAction (DeleteChannelPermission _ _) = deleteWith - toAction (TriggerTyping _) = postEmpty - toAction (GetPinnedMessages _) = getWith - toAction (AddPinnedMessage _ _) = putEmpty - toAction (DeletePinnedMessage _ _) = deleteWith - toAction (GroupDMAddRecipient _ _ o) = putWith' (toJSON o) - toAction (GroupDMRemoveRecipient _ _) = deleteWith + action (CreateMessage _ o@CreateMessageOptions { file = Nothing }) = postWith' + (toJSON . upcast @CreateMessageJson $ o) + action (CreateMessage _ o@CreateMessageOptions { file = Just f }) = postWith' + [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @CreateMessageJson $ o)] + action (GetChannel _) = getWith + action (ModifyChannel _ p) = putWith' (toJSON p) + action (DeleteChannel _) = deleteWith + action (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a)))) = getWithP + (param "around" .~ [a]) + action (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a)))) = getWithP + (param "before" .~ [a]) + action (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a)))) = getWithP + (param "after" .~ [a]) + action (GetChannelMessages _ (Just (ChannelMessagesLimit (showt -> a)))) = getWithP (param "around" .~ [a]) + action (GetChannelMessages _ Nothing) = getWith + action (GetMessage _ _) = getWith + action CreateReaction {} = putEmpty + action DeleteOwnReaction {} = deleteWith + action DeleteUserReaction {} = deleteWith + action (GetReactions _ _ _ GetReactionsOptions { before, after, limit }) = getWithP + (param "before" .~ maybeToList (showt <$> before) >>> param "after" .~ maybeToList (showt <$> after) >>> param + "limit" .~ maybeToList (showt <$> limit)) + action (DeleteAllReactions _ _) = deleteWith + action (EditMessage _ _ content embed) = patchWith' (object ["content" .= content, "embed" .= embed]) + action (DeleteMessage _ _) = deleteWith + action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (object ["messages" .= ids]) + action (GetChannelInvites _) = getWith + action (CreateChannelInvite _ o) = postWith' (toJSON o) + action (EditChannelPermissions _ o) = putWith' (toJSON o) + action (DeleteChannelPermission _ _) = deleteWith + action (TriggerTyping _) = postEmpty + action (GetPinnedMessages _) = getWith + action (AddPinnedMessage _ _) = putEmpty + action (DeletePinnedMessage _ _) = deleteWith + action (GroupDMAddRecipient _ _ o) = putWith' (toJSON o) + action (GroupDMRemoveRecipient _ _) = deleteWith 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 @@ -45,21 +45,23 @@ baseRoute :: Snowflake Guild -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild // S "emojis" & giveID id -instance Request (EmojiRequest a) a where - toRoute (ListGuildEmojis (getID -> gid)) = baseRoute gid & buildRoute - toRoute (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji +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 - toRoute (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute - toRoute (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = baseRoute gid // ID @Emoji + route (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute + route (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = baseRoute gid // ID @Emoji & giveID eid & buildRoute - toRoute (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji + route (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji & giveID eid & buildRoute - toAction (ListGuildEmojis _) = getWith - toAction (GetGuildEmoji _ _) = getWith - toAction (CreateGuildEmoji _ o) = postWith' (toJSON o) - toAction (ModifyGuildEmoji _ _ o) = patchWith' (toJSON o) - toAction (DeleteGuildEmoji _ _) = deleteWith + action (ListGuildEmojis _) = getWith + action (GetGuildEmoji _ _) = getWith + action (CreateGuildEmoji _ o) = postWith' (toJSON o) + action (ModifyGuildEmoji _ _ o) = patchWith' (toJSON o) + action (DeleteGuildEmoji _ _) = deleteWith 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 @@ -170,107 +170,109 @@ baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild & giveID id -instance Request (GuildRequest a) a where - toRoute (CreateGuild _) = mkRouteBuilder // S "guilds" +instance Request (GuildRequest a) where + type Result (GuildRequest a) = a + + route (CreateGuild _) = mkRouteBuilder // S "guilds" & buildRoute - toRoute (GetGuild (getID -> gid)) = baseRoute gid + route (GetGuild (getID -> gid)) = baseRoute gid & buildRoute - toRoute (ModifyGuild (getID -> gid) _) = baseRoute gid + route (ModifyGuild (getID -> gid) _) = baseRoute gid & buildRoute - toRoute (DeleteGuild (getID -> gid)) = baseRoute gid + route (DeleteGuild (getID -> gid)) = baseRoute gid & buildRoute - toRoute (GetGuildChannels (getID -> gid)) = baseRoute gid // S "channels" + route (GetGuildChannels (getID -> gid)) = baseRoute gid // S "channels" & buildRoute - toRoute (CreateGuildChannel (getID -> gid) _) = baseRoute gid // S "channels" + route (CreateGuildChannel (getID -> gid) _) = baseRoute gid // S "channels" & buildRoute - toRoute (ModifyGuildChannelPositions (getID -> gid) _) = baseRoute gid // S "channels" + route (ModifyGuildChannelPositions (getID -> gid) _) = baseRoute gid // S "channels" & buildRoute - toRoute (GetGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User + route (GetGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User & giveID uid & buildRoute - toRoute (ListGuildMembers (getID -> gid) _) = baseRoute gid // S "members" + route (ListGuildMembers (getID -> gid) _) = baseRoute gid // S "members" & buildRoute - toRoute (AddGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User + route (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 + route (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" + route (ModifyCurrentUserNick (getID -> gid) _) = baseRoute gid // S "members" // S "@me" // S "nick" & buildRoute - toRoute (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = + 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 - toRoute (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = + 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 - toRoute (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User + route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User & giveID uid & buildRoute - toRoute (GetGuildBans (getID -> gid)) = baseRoute gid // S "bans" + route (GetGuildBans (getID -> gid)) = baseRoute gid // S "bans" & buildRoute - toRoute (GetGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User + route (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 + route (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 + route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User & giveID uid & buildRoute - toRoute (GetGuildRoles (getID -> gid)) = baseRoute gid // S "roles" + route (GetGuildRoles (getID -> gid)) = baseRoute gid // S "roles" & buildRoute - toRoute (CreateGuildRole (getID -> gid) _) = baseRoute gid // S "roles" + route (CreateGuildRole (getID -> gid) _) = baseRoute gid // S "roles" & buildRoute - toRoute (ModifyGuildRolePositions (getID -> gid) _) = baseRoute gid // S "roles" + route (ModifyGuildRolePositions (getID -> gid) _) = baseRoute gid // S "roles" & buildRoute - toRoute (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = baseRoute gid // S "roles" // ID @Role + route (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 + route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = baseRoute gid // S "roles" // ID @Role & giveID rid & buildRoute - toRoute (GetGuildPruneCount (getID -> gid) _) = baseRoute gid // S "prune" + route (GetGuildPruneCount (getID -> gid) _) = baseRoute gid // S "prune" & buildRoute - toRoute (BeginGuildPrune (getID -> gid) _ _) = baseRoute gid // S "prune" + route (BeginGuildPrune (getID -> gid) _ _) = baseRoute gid // S "prune" & buildRoute - toRoute (GetGuildVoiceRegions (getID -> gid)) = baseRoute gid // S "regions" + route (GetGuildVoiceRegions (getID -> gid)) = baseRoute gid // S "regions" & buildRoute - toRoute (GetGuildInvites (getID -> gid)) = baseRoute gid // S "invites" + route (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 + action (CreateGuild o) = postWith' (toJSON o) + action (GetGuild _) = getWith + action (ModifyGuild _ o) = patchWith' (toJSON o) + action (DeleteGuild _) = deleteWith + action (GetGuildChannels _) = getWith + action (CreateGuildChannel _ o) = postWith' (toJSON o) + action (ModifyGuildChannelPositions _ o) = postWith' (toJSON o) + action (GetGuildMember _ _) = getWith + action (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 + action (AddGuildMember _ _ o) = putWith' (toJSON o) + action (ModifyGuildMember _ _ o) = patchWith' (toJSON o) + action (ModifyCurrentUserNick _ nick) = patchWith' (object ["nick" .= nick]) + action (AddGuildMemberRole {}) = putEmpty + action (RemoveGuildMemberRole {}) = deleteWith + action (RemoveGuildMember _ _) = deleteWith + action (GetGuildBans _) = getWith + action (GetGuildBan _ _) = getWith + action (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 + action (RemoveGuildBan _ _) = deleteWith + action (GetGuildRoles _) = getWith + action (CreateGuildRole _ o) = postWith' (toJSON o) + action (ModifyGuildRolePositions _ o) = patchWith' (toJSON o) + action (ModifyGuildRole _ _ o) = patchWith' (toJSON o) + action (DeleteGuildRole _ _) = deleteWith + action (GetGuildPruneCount _ d) = getWithP (param "days" .~ [showt d]) + action (BeginGuildPrune _ d r) = postEmptyP (param "days" .~ [showt d] >>> param "compute_prune_count" .~ [showt r]) + action (GetGuildVoiceRegions _) = getWith + action (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 @@ -25,7 +25,6 @@ import Data.Aeson hiding ( Options ) import Data.ByteString ( ByteString ) import qualified Data.ByteString.Lazy as LB -import qualified Data.Text as TS import qualified Data.Text.Encoding as TS import qualified Data.Text.Lazy as TL import Data.Text.Strict.Lens @@ -42,7 +41,7 @@ import TextShow -fromResult :: P.Member (P.Error RestError) r => Result a -> Sem r a +fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a fromResult (Success a) = pure a fromResult (Error e) = P.throw (DecodeError . TL.pack $ e) @@ -63,32 +62,31 @@ instance {-# OVERLAPS #-}FromJSON a => ReadResponse a where readResp = eitherDecode -class Request a r | a -> r where - toRoute :: a -> Route +class Request a where + type Result a - url :: a -> String - url = TS.unpack . path . toRoute + route :: a -> Route - toAction :: a -> Options -> String -> IO (Response LB.ByteString) + action :: a -> Options -> String -> IO (Response LB.ByteString) - invokeRequest :: forall reffs. (BotC reffs, FromJSON r) => a -> Sem reffs (Either RestError r) - invokeRequest a = do + invoke :: (BotC r, 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 = toRoute a + let route' = route a - inFlightRequests <- registerGauge "inflight_requests" [("route", route ^. #path)] - totalRequests <- registerCounter "total_requests" [("route", route ^. #path)] + inFlightRequests <- registerGauge "inflight_requests" [("route", route' ^. #path)] + totalRequests <- registerCounter "total_requests" [("route", route' ^. #path)] void $ modifyGauge succ inFlightRequests void $ addCounter 1 totalRequests - whenJust (route ^. #guildID) $ \guildID -> do + whenJust (route' ^. #guildID) $ \guildID -> do totalRequestsGuild <- registerCounter "total_requests" [("guild", showt guildID)] void $ addCounter 1 totalRequestsGuild - resp <- attr "route" (toRoute a ^. #path) $ doRequest rlState' route - (toAction a (requestOptions token') (route ^. #path . unpacked)) + resp <- attr "route" (route' ^. #path) $ doRequest rlState' route' + (action a (requestOptions token') (route' ^. #path . unpacked)) void $ modifyGauge pred inFlightRequests diff --git a/src/Calamity/HTTP/Invite.hs b/src/Calamity/HTTP/Invite.hs --- a/src/Calamity/HTTP/Invite.hs +++ b/src/Calamity/HTTP/Invite.hs @@ -21,11 +21,13 @@ baseRoute :: RouteBuilder _ baseRoute = mkRouteBuilder // S "invites" -instance Request (InviteRequest a) a where - toRoute (GetInvite c) = baseRoute // S c +instance Request (InviteRequest a) where + type Result (InviteRequest a) = a + + route (GetInvite c) = baseRoute // S c & buildRoute - toRoute (DeleteInvite c) = baseRoute // S c + route (DeleteInvite c) = baseRoute // S c & buildRoute - toAction (GetInvite _) = getWithP (param "with_counts" .~ [showt True]) - toAction (DeleteInvite _) = deleteWith + action (GetInvite _) = getWithP (param "with_counts" .~ [showt True]) + action (DeleteInvite _) = deleteWith 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 @@ -13,12 +13,14 @@ GetGateway :: MiscRequest GatewayResponse GetGatewayBot :: MiscRequest BotGatewayResponse -instance Request (MiscRequest a) a where - toRoute GetGateway = mkRouteBuilder // S "gateway" +instance Request (MiscRequest a) where + type Result (MiscRequest a) = a + + route GetGateway = mkRouteBuilder // S "gateway" & buildRoute - toRoute GetGatewayBot = mkRouteBuilder // S "gateway" // S "bot" + route GetGatewayBot = mkRouteBuilder // S "gateway" // S "bot" & buildRoute - toAction GetGateway = getWith - toAction GetGatewayBot = getWith + action GetGateway = getWith + action GetGatewayBot = getWith diff --git a/src/Calamity/HTTP/Reason.hs b/src/Calamity/HTTP/Reason.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Reason.hs @@ -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 Control.Lens hiding ( (.=) ) + +import Data.Text ( Text ) +import Data.Text.Encoding ( encodeUtf8 ) + +import GHC.Generics + +import Network.Wreq + +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) = action a . (header "X-Audit-Log-Reason" .~ [encodeUtf8 r]) diff --git a/src/Calamity/HTTP/User.hs b/src/Calamity/HTTP/User.hs --- a/src/Calamity/HTTP/User.hs +++ b/src/Calamity/HTTP/User.hs @@ -52,27 +52,29 @@ baseRoute :: RouteBuilder _ baseRoute = mkRouteBuilder // S "users" // S "@me" -instance Request (UserRequest a) a where - toRoute GetCurrentUser = baseRoute +instance Request (UserRequest a) where + type Result (UserRequest a) = a + + route GetCurrentUser = baseRoute & buildRoute - toRoute (GetUser (getID @User -> uid)) = mkRouteBuilder // S "users" // ID @User + route (GetUser (getID @User -> uid)) = mkRouteBuilder // S "users" // ID @User & giveID uid & buildRoute - toRoute (ModifyCurrentUser _) = baseRoute + route (ModifyCurrentUser _) = baseRoute & buildRoute - toRoute (GetCurrentUserGuilds _) = baseRoute // S "guilds" + route (GetCurrentUserGuilds _) = baseRoute // S "guilds" & buildRoute - toRoute (LeaveGuild (getID @Guild -> gid)) = baseRoute // S "guilds" // ID @Guild + route (LeaveGuild (getID @Guild -> gid)) = baseRoute // S "guilds" // ID @Guild & giveID gid & buildRoute - toRoute (CreateDM _) = baseRoute // S "channels" + route (CreateDM _) = baseRoute // S "channels" & buildRoute - toAction GetCurrentUser = getWith - toAction (GetUser _) = getWith - toAction (ModifyCurrentUser o) = patchWith' (toJSON o) - toAction (GetCurrentUserGuilds GetCurrentUserGuildsOptions { before, after, limit }) = getWithP + action GetCurrentUser = getWith + action (GetUser _) = getWith + action (ModifyCurrentUser o) = patchWith' (toJSON o) + action (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]) + action (LeaveGuild _) = deleteWith + action (CreateDM (getID @User -> uid)) = postWith' (object ["recipient_id" .= uid]) diff --git a/src/Calamity/HTTP/Webhook.hs b/src/Calamity/HTTP/Webhook.hs --- a/src/Calamity/HTTP/Webhook.hs +++ b/src/Calamity/HTTP/Webhook.hs @@ -15,7 +15,7 @@ import Control.Lens hiding ( (.=) ) import Data.Aeson -import Data.ByteString.Lazy +import Data.ByteString.Lazy ( ByteString ) import Data.Default.Class import Data.Generics.Product.Subtype ( upcast ) import Data.Maybe @@ -81,42 +81,44 @@ baseRoute :: Snowflake Webhook -> RouteBuilder _ baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id -instance Request (WebhookRequest a) a where - toRoute (CreateWebhook (getID @Channel -> cid) _) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" +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 - toRoute (GetChannelWebhooks (getID @Channel -> cid)) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" + route (GetChannelWebhooks (getID @Channel -> cid)) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" & giveID cid & buildRoute - toRoute (GetGuildWebhooks (getID @Guild -> gid)) = mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" + route (GetGuildWebhooks (getID @Guild -> gid)) = mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" & giveID gid & buildRoute - toRoute (GetWebhook (getID @Webhook -> wid)) = baseRoute wid + route (GetWebhook (getID @Webhook -> wid)) = baseRoute wid & buildRoute - toRoute (GetWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t + route (GetWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t & buildRoute - toRoute (ModifyWebhook (getID @Webhook -> wid) _) = baseRoute wid + route (ModifyWebhook (getID @Webhook -> wid) _) = baseRoute wid & buildRoute - toRoute (ModifyWebhookToken (getID @Webhook -> wid) t _) = baseRoute wid // S t + route (ModifyWebhookToken (getID @Webhook -> wid) t _) = baseRoute wid // S t & buildRoute - toRoute (DeleteWebhook (getID @Webhook -> wid)) = baseRoute wid + route (DeleteWebhook (getID @Webhook -> wid)) = baseRoute wid & buildRoute - toRoute (DeleteWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t + route (DeleteWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t & buildRoute - toRoute (ExecuteWebhook (getID @Webhook -> wid) t _) = baseRoute wid // S t + route (ExecuteWebhook (getID @Webhook -> wid) t _) = baseRoute wid // S t & buildRoute - toAction (CreateWebhook _ o) = postWith' (toJSON o) - toAction (GetChannelWebhooks _) = getWith - toAction (GetGuildWebhooks _) = getWith - toAction (GetWebhook _) = getWith - toAction (GetWebhookToken _ _) = getWith - toAction (ModifyWebhook _ o) = patchWith' (toJSON o) - toAction (ModifyWebhookToken _ _ o) = patchWith' (toJSON o) - toAction (DeleteWebhook _) = deleteWith - toAction (DeleteWebhookToken _ _) = deleteWith - toAction (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Nothing }) = postWithP' + action (CreateWebhook _ o) = postWith' (toJSON o) + action (GetChannelWebhooks _) = getWith + action (GetGuildWebhooks _) = getWith + action (GetWebhook _) = getWith + action (GetWebhookToken _ _) = getWith + action (ModifyWebhook _ o) = patchWith' (toJSON o) + action (ModifyWebhookToken _ _ o) = patchWith' (toJSON o) + action (DeleteWebhook _) = deleteWith + action (DeleteWebhookToken _ _) = deleteWith + action (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Nothing }) = postWithP' (toJSON . upcast @ExecuteWebhookJson $ o) (param "wait" .~ maybeToList (showt <$> o ^. #wait)) - toAction (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Just f }) = postWithP' + action (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Just f }) = postWithP' [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ o)] (param "wait" .~ maybeToList (showt <$> o ^. #wait)) 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 @@ -236,4 +236,5 @@ pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed instance ToJSON a => ToJSON (SnowflakeMap a) where + toJSON = toJSON . elems toEncoding = toEncoding . elems diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs --- a/src/Calamity/Internal/Utils.hs +++ b/src/Calamity/Internal/Utils.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-orphans #-} + -- | Internal utilities and instances module Calamity.Internal.Utils ( whenJust @@ -65,7 +66,7 @@ instance (TextShow a, VU.Unbox a) => TextShow (Vector a) where showb = showbList . VU.toList - -- lazy and strict use the same internal data structure + -- lazy and strict use the same internal data structure instance (Show k, Show v) => TextShow (LH.HashMap k v) where showb = fromString . show diff --git a/src/Calamity/Types.hs b/src/Calamity/Types.hs --- a/src/Calamity/Types.hs +++ b/src/Calamity/Types.hs @@ -4,10 +4,12 @@ , module Calamity.Types.Partial , module Calamity.Types.Snowflake , module Calamity.Types.Token + , module Calamity.Types.Tellable , module Calamity.Types.UnixTimestamp ) where import Calamity.Types.Model import Calamity.Types.Partial import Calamity.Types.Snowflake import Calamity.Types.Token +import Calamity.Types.Tellable import Calamity.Types.UnixTimestamp diff --git a/src/Calamity/Types/Model/Channel/Attachment.hs b/src/Calamity/Types/Model/Channel/Attachment.hs --- a/src/Calamity/Types/Model/Channel/Attachment.hs +++ b/src/Calamity/Types/Model/Channel/Attachment.hs @@ -33,12 +33,16 @@ deriving ( HasID Attachment ) via HasIDField "id" Attachment instance ToJSON Attachment where - toEncoding Attachment { id, filename, size, url, proxyUrl, dimensions = Just (width, height) } = pairs - ("id" .= id <> "filename" .= filename <> "size" .= size <> "url" .= url <> "proxy_url" .= proxyUrl - <> "width" .= width <> "height" .= height) - - toEncoding Attachment { id, filename, size, url, proxyUrl } = pairs - ("id" .= id <> "filename" .= filename <> "size" .= size <> "url" .= url <> "proxy_url" .= proxyUrl) + 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 diff --git a/src/Calamity/Types/Model/Channel/Embed.hs b/src/Calamity/Types/Model/Channel/Embed.hs --- a/src/Calamity/Types/Model/Channel/Embed.hs +++ b/src/Calamity/Types/Model/Channel/Embed.hs @@ -12,7 +12,12 @@ import Calamity.Internal.AesonThings import Calamity.Internal.Utils () +import Control.Lens + import Data.Aeson +import Data.Default.Class +import Data.Generics.Labels () +import Data.Semigroup import Data.Text.Lazy ( Text ) import Data.Time import Data.Word @@ -37,12 +42,31 @@ , author :: Maybe EmbedAuthor , fields :: [EmbedField] } - deriving ( Eq, Show, Generic ) + deriving ( Eq, Show, Generic, Default ) deriving ( TextShow ) via TSG.FromGeneric Embed deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed deriving ( ToJSON ) via CalamityJSON Embed +instance Semigroup Embed where + l <> r = l + & #title %~ (<> (r ^. #title)) + & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last + & #description %~ (<> (r ^. #description)) + & #url %~ getLast . (<> Last (r ^. #url)) . Last + & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last + & #color %~ getLast . (<> Last (r ^. #color)) . Last + & #footer %~ (<> (r ^. #footer)) + & #image %~ getLast . (<> Last (r ^. #image)) . Last + & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last + & #video %~ getLast . (<> Last (r ^. #video)) . Last + & #provider %~ getLast . (<> Last (r ^. #provider)) . Last + & #author %~ getLast . (<> Last (r ^. #author)) . Last + & #fields %~ (<> (r ^. #fields)) + +instance Monoid Embed where + mempty = def + data EmbedFooter = EmbedFooter { text :: Text , iconUrl :: Maybe Text @@ -51,6 +75,12 @@ deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric EmbedFooter deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedFooter + +instance Semigroup EmbedFooter where + l <> r = l + & #text %~ (<> (r ^. #text)) + & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last + & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last data EmbedImage = EmbedImage { url :: Text 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.Ban + ( module Calamity.Types.Model.Guild.AuditLog + , module Calamity.Types.Model.Guild.Ban , module Calamity.Types.Model.Guild.Emoji , module Calamity.Types.Model.Guild.Guild , module Calamity.Types.Model.Guild.Member @@ -9,6 +10,7 @@ , module Calamity.Types.Model.Guild.Role , module Calamity.Types.Model.Guild.UnavailableGuild ) where +import Calamity.Types.Model.Guild.AuditLog import Calamity.Types.Model.Guild.Ban import Calamity.Types.Model.Guild.Emoji import Calamity.Types.Model.Guild.Guild hiding ( UpdatedGuild(..) ) diff --git a/src/Calamity/Types/Model/Guild/AuditLog.hs b/src/Calamity/Types/Model/Guild/AuditLog.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/AuditLog.hs @@ -0,0 +1,187 @@ +-- | Audit Log models +module Calamity.Types.Model.Guild.AuditLog + ( AuditLog(..) + , AuditLogEntry(..) + , AuditLogEntryInfo(..) + , AuditLogChange(..) + , AuditLogAction(..) ) where + +import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.User +import Calamity.Types.Snowflake + +import Data.Aeson +import Data.Scientific +import Data.Text.Lazy ( Text ) + +import GHC.Generics + +import TextShow +import qualified TextShow.Generic as TSG + +data AuditLog = AuditLog + { webhooks :: SnowflakeMap Webhook + , users :: SnowflakeMap User + , auditLogEntries :: SnowflakeMap AuditLogEntry + } + deriving ( Show, Generic ) + deriving ( TextShow ) via TSG.FromGeneric AuditLog + deriving ( FromJSON ) via CalamityJSON AuditLog + +data AuditLogEntry = AuditLogEntry + { targetID :: Maybe (Snowflake ()) + , changes :: [AuditLogChange] + , userID :: Snowflake User + , id :: Snowflake AuditLogEntry + , actionType :: AuditLogAction + , options :: Maybe AuditLogEntryInfo + , reason :: Maybe Text + } + deriving ( Show, Generic ) + deriving ( TextShow ) via TSG.FromGeneric AuditLogEntry + deriving ( FromJSON ) via CalamityJSON AuditLogEntry + deriving ( HasID User ) via HasIDField "userID" AuditLogEntry + deriving ( HasID AuditLogEntry ) via HasIDField "id" AuditLogEntry + +data AuditLogEntryInfo = AuditLogEntryInfo + { deleteMemberDays :: Maybe Text + , membersRemoved :: Maybe Text + , channelID :: Maybe (Snowflake Channel) + , messageID :: Maybe (Snowflake Message) + , count :: Maybe Text + , id :: Maybe (Snowflake ()) + , type_ :: Maybe Text + , roleName :: Maybe Text + } + deriving ( Show, Generic ) + deriving ( TextShow ) via TSG.FromGeneric AuditLogEntryInfo + deriving ( FromJSON ) via CalamityJSON AuditLogEntryInfo + +data AuditLogChange = AuditLogChange + { newValue :: Maybe Value + , oldValue :: Maybe Value + , key :: Text + } + deriving ( Show, Generic ) + deriving ( TextShow ) via FromStringShow AuditLogChange + deriving ( FromJSON ) via CalamityJSON AuditLogChange + +data AuditLogAction + = GUILD_UPDATE + | CHANNEL_CREATE + | CHANNEL_UPDATE + | CHANNEL_DELETE + | CHANNEL_OVERWRITE_CREATE + | CHANNEL_OVERWRITE_UPDATE + | CHANNEL_OVERWRITE_DELETE + | MEMBER_KICK + | MEMBER_PRUNE + | MEMBER_BAN_ADD + | MEMBER_BAN_REMOVE + | MEMBER_UPDATE + | MEMBER_ROLE_UPDATE + | MEMBER_MOVE + | MEMBER_DISCONNECT + | BOT_ADD + | ROLE_CREATE + | ROLE_UPDATE + | ROLE_DELETE + | INVITE_CREATE + | INVITE_UPDATE + | INVITE_DELETE + | WEBHOOK_CREATE + | WEBHOOK_UPDATE + | WEBHOOK_DELETE + | EMOJI_CREATE + | EMOJI_UPDATE + | EMOJI_DELETE + | MESSAGE_DELETE + | MESSAGE_BULK_DELETE + | MESSAGE_PIN + | MESSAGE_UNPIN + | INTEGRATION_CREATE + | INTEGRATION_UPDATE + | INTEGRATION_DELETE + deriving ( Show, Generic ) + deriving ( TextShow ) via TSG.FromGeneric AuditLogAction + +instance FromJSON AuditLogAction where + parseJSON = withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 1 -> pure GUILD_UPDATE + 10 -> pure CHANNEL_CREATE + 11 -> pure CHANNEL_UPDATE + 12 -> pure CHANNEL_DELETE + 13 -> pure CHANNEL_OVERWRITE_CREATE + 14 -> pure CHANNEL_OVERWRITE_UPDATE + 15 -> pure CHANNEL_OVERWRITE_DELETE + 20 -> pure MEMBER_KICK + 21 -> pure MEMBER_PRUNE + 22 -> pure MEMBER_BAN_ADD + 23 -> pure MEMBER_BAN_REMOVE + 24 -> pure MEMBER_UPDATE + 25 -> pure MEMBER_ROLE_UPDATE + 26 -> pure MEMBER_MOVE + 27 -> pure MEMBER_DISCONNECT + 28 -> pure BOT_ADD + 30 -> pure ROLE_CREATE + 31 -> pure ROLE_UPDATE + 32 -> pure ROLE_DELETE + 40 -> pure INVITE_CREATE + 41 -> pure INVITE_UPDATE + 42 -> pure INVITE_DELETE + 50 -> pure WEBHOOK_CREATE + 51 -> pure WEBHOOK_UPDATE + 52 -> pure WEBHOOK_DELETE + 60 -> pure EMOJI_CREATE + 61 -> pure EMOJI_UPDATE + 62 -> pure EMOJI_DELETE + 72 -> pure MESSAGE_DELETE + 73 -> pure MESSAGE_BULK_DELETE + 74 -> pure MESSAGE_PIN + 75 -> pure MESSAGE_UNPIN + 80 -> pure INTEGRATION_CREATE + 81 -> pure INTEGRATION_UPDATE + 82 -> pure INTEGRATION_DELETE + _ -> fail $ "Invalid AuditLogAction: " <> show n + Nothing -> fail $ "Invalid AuditLogAction: " <> show n + +instance ToJSON AuditLogAction where + toJSON x = toJSON @Int $ case x of + GUILD_UPDATE -> 1 + CHANNEL_CREATE -> 10 + CHANNEL_UPDATE -> 11 + CHANNEL_DELETE -> 12 + CHANNEL_OVERWRITE_CREATE -> 13 + CHANNEL_OVERWRITE_UPDATE -> 14 + CHANNEL_OVERWRITE_DELETE -> 15 + MEMBER_KICK -> 20 + MEMBER_PRUNE -> 21 + MEMBER_BAN_ADD -> 22 + MEMBER_BAN_REMOVE -> 23 + MEMBER_UPDATE -> 24 + MEMBER_ROLE_UPDATE -> 25 + MEMBER_MOVE -> 26 + MEMBER_DISCONNECT -> 27 + BOT_ADD -> 28 + ROLE_CREATE -> 30 + ROLE_UPDATE -> 31 + ROLE_DELETE -> 32 + INVITE_CREATE -> 40 + INVITE_UPDATE -> 41 + INVITE_DELETE -> 42 + WEBHOOK_CREATE -> 50 + WEBHOOK_UPDATE -> 51 + WEBHOOK_DELETE -> 52 + EMOJI_CREATE -> 60 + EMOJI_UPDATE -> 61 + EMOJI_DELETE -> 62 + MESSAGE_DELETE -> 72 + MESSAGE_BULK_DELETE -> 73 + MESSAGE_PIN -> 74 + MESSAGE_UNPIN -> 75 + INTEGRATION_CREATE -> 80 + INTEGRATION_UPDATE -> 81 + INTEGRATION_DELETE -> 82 diff --git a/src/Calamity/Types/Model/Guild/Emoji.hs b/src/Calamity/Types/Model/Guild/Emoji.hs --- a/src/Calamity/Types/Model/Guild/Emoji.hs +++ b/src/Calamity/Types/Model/Guild/Emoji.hs @@ -50,8 +50,8 @@ deriving ( TextShow ) via TSG.FromGeneric RawEmoji instance ToJSON RawEmoji where - toEncoding (CustomEmoji e) = pairs $ "emoji" .= e - toEncoding (UnicodeEmoji s) = pairs $ "emoji" .= (("name" .= s) :: Object) + toJSON (CustomEmoji e) = object ["emoji" .= e] + toJSON (UnicodeEmoji s) = object ["emoji" .= object ["name" .= s]] instance FromJSON RawEmoji where parseJSON = withObject "RawEmoji" $ \v -> do diff --git a/src/Calamity/Types/Model/Presence/Activity.hs b/src/Calamity/Types/Model/Presence/Activity.hs --- a/src/Calamity/Types/Model/Presence/Activity.hs +++ b/src/Calamity/Types/Model/Presence/Activity.hs @@ -63,8 +63,8 @@ deriving ( TextShow ) via TSG.FromGeneric ActivityTimestamps instance ToJSON ActivityTimestamps where - toEncoding ActivityTimestamps { start, end } = pairs - ("start" .= (unixToMilliseconds <$> start) <> "end" .= (unixToMilliseconds <$> end)) + toJSON ActivityTimestamps { start, end } = object + ["start" .= (unixToMilliseconds <$> start), "end" .= (unixToMilliseconds <$> end)] instance FromJSON ActivityTimestamps where parseJSON = withObject "ActivityTimestamps" $ \v -> do diff --git a/src/Calamity/Types/Tellable.hs b/src/Calamity/Types/Tellable.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Tellable.hs @@ -0,0 +1,105 @@ +-- | Things that are messageable +module Calamity.Types.Tellable + ( ToMessage(..) + , Tellable(..) + , TFile(..) + , tell ) where + +import Calamity.Client.Types +import Calamity.HTTP +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake + +import Control.Lens + +import Data.ByteString.Lazy ( ByteString ) +import Data.Default.Class +import Data.Monoid +import Data.Text ( Text ) + +import GHC.Generics + +import qualified Polysemy as P +import qualified Polysemy.Error as P + +-- | A wrapper type for sending files +newtype TFile = TFile ByteString + deriving ( Show, Generic ) + +-- | Things that can be used to send a message +-- +-- Can be used to compose text, embeds, and files. /e.g./ +-- +-- @ +-- 'intoMsg' @'Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description") +-- @ +class ToMessage a where + intoMsg :: a -> Endo CreateMessageOptions + +-- | Message content, '(<>)' concatenates the content +instance ToMessage Text where + intoMsg t = Endo (#content %~ (<> Just t)) + +-- | Message embed, '(<>)' merges embeds using '(<>)' +instance ToMessage Embed where + intoMsg e = Endo (#embed %~ (<> Just e)) + +-- | Message file, '(<>)' keeps the last added file +instance ToMessage TFile where + intoMsg (TFile f) = Endo (#file %~ getLast . (<> Last (Just f)) . Last) + +instance ToMessage (Endo CreateMessageOptions) where + intoMsg = Prelude.id + +instance ToMessage (CreateMessageOptions -> CreateMessageOptions) where + intoMsg = Endo + +instance ToMessage CreateMessageOptions where + intoMsg = Endo . const + +class Tellable a where + getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel) + +runToMessage :: ToMessage a => a -> CreateMessageOptions +runToMessage = flip appEndo def . intoMsg + +-- | Send a message to something that is messageable +tell :: forall msg r t. (BotC r, ToMessage msg, Tellable t) => t -> msg -> P.Sem r (Either RestError Message) +tell target (runToMessage -> msg) = P.runError $ do + cid <- getChannel target + r <- invoke $ CreateMessage cid msg + P.fromEither r + +instance Tellable DMChannel where + getChannel = pure . getID + +instance Tellable (Snowflake DMChannel) where + getChannel = pure . coerceSnowflake + +instance Tellable TextChannel where + getChannel = pure . getID + +instance Tellable (Snowflake TextChannel) where + getChannel = pure . coerceSnowflake + +instance Tellable Message where + getChannel = pure . getID + +messageUser :: (BotC r, P.Member (P.Error RestError) r, HasID User a) => a -> P.Sem r (Snowflake Channel) +messageUser (getID @User -> uid) = do + c <- invoke $ CreateDM uid + getID <$> P.fromEither c + +instance Tellable (Snowflake Member) where + getChannel = messageUser . coerceSnowflake @_ @User + +instance Tellable Member where + getChannel = messageUser + +instance Tellable User where + getChannel = messageUser + +instance Tellable (Snowflake User) where + getChannel = messageUser diff --git a/src/Calamity/Types/UnixTimestamp.hs b/src/Calamity/Types/UnixTimestamp.hs --- a/src/Calamity/Types/UnixTimestamp.hs +++ b/src/Calamity/Types/UnixTimestamp.hs @@ -40,6 +40,11 @@ >>> UnixTimestamp instance ToJSON UnixTimestamp where + toJSON = unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> round + >>> toJSON @Word64 toEncoding = unUnixTimestamp >>> utcTimeToPOSIXSeconds >>> toRational