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: be510d66d49f55eee979f88e81ccd03d77fc73990d6f0cbc83c7242e64ddeec7 +-- hash: 5c7efe15b2591781800d2351bc951927dd700e2f79d18d28ae979dc7dfe58f0b name: calamity -version: 0.1.4.3 +version: 0.1.4.4 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -55,6 +55,7 @@ Calamity.HTTP.Invite Calamity.HTTP.MiscRoutes Calamity.HTTP.User + Calamity.HTTP.Webhook Calamity.Internal.AesonThings Calamity.Internal.BoundedStore Calamity.Internal.SnowflakeMap diff --git a/src/Calamity/HTTP.hs b/src/Calamity/HTTP.hs --- a/src/Calamity/HTTP.hs +++ b/src/Calamity/HTTP.hs @@ -6,7 +6,8 @@ , module Calamity.HTTP.Guild , module Calamity.HTTP.Invite , module Calamity.HTTP.MiscRoutes - , module Calamity.HTTP.User ) where + , module Calamity.HTTP.User + , module Calamity.HTTP.Webhook ) where import Calamity.HTTP.Channel import Calamity.HTTP.Emoji @@ -15,3 +16,4 @@ import Calamity.HTTP.Invite import Calamity.HTTP.MiscRoutes import Calamity.HTTP.User +import Calamity.HTTP.Webhook 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 @@ -2,6 +2,7 @@ module Calamity.HTTP.Internal.Request ( Request(..) , postWith' + , postWithP' , putWith' , patchWith' , putEmpty @@ -105,6 +106,9 @@ postWith' :: Postable a => a -> Options -> String -> IO (Response LB.ByteString) postWith' p o s = postWith o s p + +postWithP' :: Postable a => a -> (Options -> Options) -> Options -> String -> IO (Response LB.ByteString) +postWithP' p oF o s = postWith (oF o) s p postEmpty :: Options -> String -> IO (Response LB.ByteString) postEmpty o s = postWith o s ("" :: ByteString) diff --git a/src/Calamity/HTTP/Webhook.hs b/src/Calamity/HTTP/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Webhook.hs @@ -0,0 +1,122 @@ +-- | Webhook endpoints +module Calamity.HTTP.Webhook + ( WebhookRequest(..) + , CreateWebhookData(..) + , ModifyWebhookData(..) + , ExecuteWebhookOptions(..) ) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.AesonThings +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake + +import Control.Lens hiding ( (.=) ) + +import Data.Aeson +import Data.ByteString.Lazy +import Data.Default.Class +import Data.Generics.Product.Subtype ( upcast ) +import Data.Maybe +import Data.Text ( Text ) + +import GHC.Generics + +import Network.Wreq + +import TextShow + +data CreateWebhookData = CreateWebhookData + { 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 CreateWebhookData + +data ModifyWebhookData = ModifyWebhookData + { 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 + , channelID :: Maybe (Snowflake Channel) + } + deriving ( Show, Generic, Default ) + deriving ( ToJSON ) via CalamityJSON ModifyWebhookData + +data ExecuteWebhookOptions = ExecuteWebhookOptions + { wait :: Maybe Bool + , content :: Maybe Text + , file :: Maybe ByteString + , embeds :: Maybe [Embed] + , username :: Maybe Text + , avatarUrl :: Maybe Text + , tts :: Maybe Bool + } + deriving ( Show, Generic, Default ) + +data ExecuteWebhookJson = ExecuteWebhookJson + { content :: Maybe Text + , embeds :: Maybe [Embed] + , username :: Maybe Text + , avatarUrl :: Maybe Text + , tts :: Maybe Bool + } + deriving ( Show, Generic ) + deriving ( ToJSON ) via CalamityJSON ExecuteWebhookJson + +data WebhookRequest a where + CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook + GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook] + GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook] + GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook + GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook + ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook + ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook + DeleteWebhook :: HasID Webhook w => w -> WebhookRequest () + DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest () + ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () + + +baseRoute :: Snowflake Webhook -> RouteBuilder _ +baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id + +instance Request (WebhookRequest a) a where + toRoute (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" + & giveID cid + & buildRoute + toRoute (GetGuildWebhooks (getID @Guild -> gid)) = mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" + & giveID gid + & buildRoute + toRoute (GetWebhook (getID @Webhook -> wid)) = baseRoute wid + & buildRoute + toRoute (GetWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t + & buildRoute + toRoute (ModifyWebhook (getID @Webhook -> wid) _) = baseRoute wid + & buildRoute + toRoute (ModifyWebhookToken (getID @Webhook -> wid) t _) = baseRoute wid // S t + & buildRoute + toRoute (DeleteWebhook (getID @Webhook -> wid)) = baseRoute wid + & buildRoute + toRoute (DeleteWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t + & buildRoute + toRoute (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' + (toJSON . upcast @ExecuteWebhookJson $ o) (param "wait" .~ maybeToList (showt <$> o ^. #wait)) + toAction (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Just f }) = postWithP' + [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ o)] + (param "wait" .~ maybeToList (showt <$> o ^. #wait))