diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs --- a/Calamity/HTTP/Channel.hs +++ b/Calamity/HTTP/Channel.hs @@ -46,6 +46,7 @@ , file :: Maybe (Text, ByteString) , embed :: Maybe Embed , allowedMentions :: Maybe AllowedMentions + , messageReference :: Maybe MessageReference } deriving (Show, Generic, Default) @@ -64,13 +65,17 @@ { parse :: [AllowedMentionType] , roles :: [Snowflake Role] , users :: [Snowflake User] + , repliedUser :: Bool } - deriving (Show, Generic, Default) + deriving (Show, Generic) deriving (ToJSON) via CalamityJSON AllowedMentions +instance Default AllowedMentions where + def = AllowedMentions def def def False + instance Semigroup AllowedMentions where - AllowedMentions p0 r0 u0 <> AllowedMentions p1 r1 u1 = - AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1) + AllowedMentions p0 r0 u0 ru0 <> AllowedMentions p1 r1 u1 ru1 = + AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1) (ru0 || ru1) instance Monoid AllowedMentions where mempty = def @@ -80,6 +85,8 @@ , nonce :: Maybe Text , tts :: Maybe Bool , embed :: Maybe Embed + , allowedMentions :: Maybe AllowedMentions + , messageReference :: Maybe MessageReference } deriving (Show, Generic) deriving (ToJSON) via CalamityJSON CreateMessageJson @@ -167,6 +174,7 @@ data ChannelRequest a where CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message + CrosspostMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> EditMessageData -> ChannelRequest Message DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () @@ -202,6 +210,10 @@ route (CreateMessage (getID -> id) _) = baseRoute id // S "messages" & buildRoute + route (CrosspostMessage (getID -> id) (getID @Message -> mid)) = + baseRoute id // S "messages" // ID @Message + & giveID mid + & buildRoute route (GetChannel (getID -> id)) = baseRoute id & buildRoute @@ -298,6 +310,7 @@ } body <- reqBodyMultipart [filePart, partLBS "payload_json" (encode . upcast @CreateMessageJson $ cm)] postWith' body u o + action (CrosspostMessage _ _) = postEmpty action (GetChannel _) = getWith action (ModifyChannel _ p) = putWith' (ReqBodyJson p) action (DeleteChannel _) = deleteWith diff --git a/Calamity/Internal/AesonThings.hs b/Calamity/Internal/AesonThings.hs --- a/Calamity/Internal/AesonThings.hs +++ b/Calamity/Internal/AesonThings.hs @@ -8,6 +8,7 @@ , DefaultToEmptyArray , DefaultToZero , DefaultToFalse + , DefaultToTrue , CalamityJSON(..) , CalamityJSONKeepNothing(..) , jsonOptions @@ -106,6 +107,11 @@ instance Reifies DefaultToFalse Value where reflect _ = Bool False + +data DefaultToTrue + +instance Reifies DefaultToTrue Value where + reflect _ = Bool True newtype CalamityJSON a = CalamityJSON { unCalamityJSON :: a diff --git a/Calamity/Types/Model/Channel.hs b/Calamity/Types/Model/Channel.hs --- a/Calamity/Types/Model/Channel.hs +++ b/Calamity/Types/Model/Channel.hs @@ -19,7 +19,7 @@ import Calamity.Types.Model.Channel.Embed import Calamity.Types.Model.Channel.Group import Calamity.Types.Model.Channel.Guild -import {-# SOURCE #-} Calamity.Types.Model.Channel.Message +import Calamity.Types.Model.Channel.Message import Calamity.Types.Model.Channel.Reaction import Calamity.Types.Model.Channel.Webhook import Calamity.Types.Partial diff --git a/Calamity/Types/Model/Channel/Message.hs b/Calamity/Types/Model/Channel/Message.hs --- a/Calamity/Types/Model/Channel/Message.hs +++ b/Calamity/Types/Model/Channel/Message.hs @@ -1,60 +1,93 @@ -- | A message from a channel -module Calamity.Types.Model.Channel.Message - ( Message(..) - , MessageType(..) ) where +module Calamity.Types.Model.Channel.Message ( + Message (..), + MessageType (..), + MessageReference (..), +) where -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils () +import {-# SOURCE #-} Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.Attachment +import Calamity.Types.Model.Channel.Embed +import Calamity.Types.Model.Channel.Reaction +import Calamity.Types.Model.Channel.Webhook import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Data.Aeson -import Data.Scientific -import Data.Text.Lazy ( Text ) -import Data.Time -import qualified Data.Vector.Unboxing as UV +import Data.Aeson +import Data.Scientific +import Data.Text.Lazy (Text) +import Data.Time +import qualified Data.Vector.Unboxing as UV -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Data.Word (Word64) +import TextShow +import qualified TextShow.Generic as TSG --- NOTE: make sure we fill in the guildID field when retrieving from REST data Message = Message - { id :: Snowflake Message - , channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , author :: Snowflake User - , content :: Text - , timestamp :: UTCTime + { id :: Snowflake Message + , channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , author :: Snowflake User + , content :: Text + , timestamp :: UTCTime , editedTimestamp :: Maybe UTCTime - , tts :: Bool + , tts :: Bool , mentionEveryone :: Bool - , mentions :: UV.Vector (Snowflake User) - , mentionRoles :: UV.Vector (Snowflake Role) + , mentions :: UV.Vector (Snowflake User) + , mentionRoles :: UV.Vector (Snowflake Role) , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: ![Attachment] - , embeds :: ![Embed] - , reactions :: ![Reaction] - , nonce :: Maybe (Snowflake Message) - , pinned :: Bool - , webhookID :: Maybe (Snowflake ()) - , type_ :: !MessageType + , attachments :: ![Attachment] + , embeds :: ![Embed] + , reactions :: ![Reaction] + , nonce :: Maybe (Snowflake Message) + , pinned :: Bool + , webhookID :: Maybe (Snowflake Webhook) + , type_ :: !MessageType + , activity :: Maybe Object + , application :: Maybe Object + , messageReference :: Maybe MessageReference + , flags :: Word64 + , stickers :: Maybe [Object] + , referencedMessage :: Maybe Message + , interaction :: Maybe Object } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Message - deriving ( FromJSON ) via WithSpecialCases - '["author" `ExtractFieldFrom` "id", "mentions" `ExtractArrayField` "id", - "mention_channels" `ExtractArrayField` "id", - "reactions" `IfNoneThen` DefaultToEmptyArray] - Message - deriving ( HasID Message ) via HasIDField "id" Message - deriving ( HasID Channel ) via HasIDField "channelID" Message - deriving ( HasID User ) via HasIDField "author" Message + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric Message + deriving + (FromJSON) + via WithSpecialCases + '[ "author" `ExtractFieldFrom` "id" + , "mentions" `ExtractArrayField` "id" + , "mention_channels" `ExtractArrayField` "id" + , "reactions" `IfNoneThen` DefaultToEmptyArray + ] + Message + deriving (HasID Message) via HasIDField "id" Message + deriving (HasID Channel) via HasIDField "channelID" Message + deriving (HasID User) via HasIDField "author" Message +data MessageReference = MessageReference + { messageID :: Maybe (Snowflake Message) + , channelID :: Maybe (Snowflake Channel) + , guildID :: Maybe (Snowflake Guild) + , failIfNotExists :: Bool + } + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric MessageReference + deriving + (FromJSON) + via WithSpecialCases + '[ "fail_if_not_exists" `IfNoneThen` DefaultToTrue + ] + MessageReference + deriving (ToJSON) via CalamityJSON MessageReference + -- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L264) data MessageType = Default @@ -72,12 +105,14 @@ | ChannelFollowAdd | GuildDiscoveryDisqualified | GuildDiscoveryRequalified - deriving ( Eq, Show, Enum, Generic ) - deriving ( TextShow ) via TSG.FromGeneric MessageType + | Reply + | ApplicationCommmand + deriving (Eq, Show, Enum, Generic) + deriving (TextShow) via TSG.FromGeneric MessageType instance FromJSON MessageType where parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of - Just !v -> case v of + Just !v -> case v of 0 -> pure Default 1 -> pure RecipientAdd 2 -> pure RecipientRemove @@ -91,7 +126,9 @@ 10 -> pure UserPremiumGuildSubscriptionTier2 11 -> pure UserPremiumGuildSubscriptionTier3 12 -> pure ChannelFollowAdd - 13 -> pure GuildDiscoveryDisqualified - 14 -> pure GuildDiscoveryRequalified + 14 -> pure GuildDiscoveryDisqualified + 15 -> pure GuildDiscoveryRequalified + 19 -> pure Reply + 20 -> pure ApplicationCommmand _ -> fail $ "Invalid MessageType: " <> show n Nothing -> fail $ "Invalid MessageType: " <> show n diff --git a/Calamity/Types/Model/Channel/Message.hs-boot b/Calamity/Types/Model/Channel/Message.hs-boot --- a/Calamity/Types/Model/Channel/Message.hs-boot +++ b/Calamity/Types/Model/Channel/Message.hs-boot @@ -1,7 +1,8 @@ -- | A message from a channel module Calamity.Types.Model.Channel.Message ( Message - , MessageType ) where + , MessageType + , MessageReference ) where data Message @@ -12,3 +13,8 @@ instance Show MessageType instance Eq MessageType + +data MessageReference + +instance Show MessageReference +instance Eq MessageReference diff --git a/Calamity/Types/Tellable.hs b/Calamity/Types/Tellable.hs --- a/Calamity/Types/Tellable.hs +++ b/Calamity/Types/Tellable.hs @@ -1,48 +1,54 @@ -- | Things that are messageable -module Calamity.Types.Tellable - ( ToMessage(..) - , Tellable(..) - , TFile(..) - , TMention(..) - , tell ) where +module Calamity.Types.Tellable ( + ToMessage (..), + Tellable (..), + TFile (..), + TMention (..), + tell, + reply, +) 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 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 Control.Lens -import Data.ByteString.Lazy ( ByteString ) -import Data.Default.Class -import Data.Monoid -import qualified Data.Text as S -import qualified Data.Text.Lazy as L +import Data.ByteString.Lazy (ByteString) +import Data.Default.Class +import Data.Monoid +import qualified Data.Text as S +import qualified Data.Text.Lazy as L -import GHC.Generics +import GHC.Generics -import qualified Polysemy as P -import qualified Polysemy.Error as P +import qualified Polysemy as P +import qualified Polysemy.Error as P -- | A wrapper type for sending files -data TFile = TFile - S.Text -- ^ The filename - ByteString -- ^ The content - deriving ( Show, Generic ) +data TFile + = TFile + S.Text + -- ^ The filename + ByteString + -- ^ The content + deriving (Show, Generic) -- | A wrapper type for allowing mentions newtype TMention a = TMention (Snowflake a) - deriving ( Show, Generic ) + deriving (Show, Generic) --- | Things that can be used to send a message --- --- Can be used to compose text, embeds, and files. /e.g./ --- --- @ --- 'intoMsg' @'L.Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description") --- @ +{- | Things that can be used to send a message + + Can be used to compose text, embeds, and files. /e.g./ + + @ + 'intoMsg' @'L.Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description") + @ +-} class ToMessage a where -- | Turn @a@ into a 'CreateMessageOptions' builder intoMsg :: a -> Endo CreateMessageOptions @@ -83,6 +89,10 @@ instance ToMessage (TMention Role) where intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles <>~ [s]) +-- | Set a 'MessageReference' as the message to reply to +instance ToMessage MessageReference where + intoMsg ref = Endo (#messageReference ?~ ref) + instance ToMessage (Endo CreateMessageOptions) where intoMsg = Prelude.id @@ -98,22 +108,42 @@ runToMessage :: ToMessage a => a -> CreateMessageOptions runToMessage = flip appEndo def . intoMsg --- | Send a message to something that is messageable --- --- To send a string literal you'll probably want to use @TypeApplication@ to --- specify the type of @msg@ --- --- ==== Examples --- --- Sending a string: --- --- @ --- 'void' $ 'tell' @'Text' m ("Somebody told me to tell you about: " '<>' s) --- @ +{- | Send a message to something that is messageable + + To send a string literal you'll probably want to use @TypeApplication@ to + specify the type of @msg@ + + ==== Examples + + Sending a string: + + @ + 'void' $ 'tell' @'Text' m ("Somebody told me to tell you about: " '<>' s) + @ +-} 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 + +{- | Create a reply to an existing message in the same channel + + To send a string literal you'll probably want to use @TypeApplication@ to + specify the type of @msg@ + + ==== Examples + + Sending a string: + + @ + 'void' $ 'reply' @'Text' msgToReplyTo ("Somebody told me to tell you about: " '<>' s) + @ +-} +reply :: forall msg r t. (BotC r, ToMessage msg, HasID Channel t, HasID Message t) => t -> msg -> P.Sem r (Either RestError Message) +reply target msg = P.runError $ do + let msg' = runToMessage (intoMsg msg <> intoMsg (MessageReference (Just $ getID @Message target) (Just $ getID @Channel target) Nothing False)) + r <- invoke $ CreateMessage (getID @Channel target) msg' P.fromEither r instance Tellable DMChannel where diff --git a/Calamity/Utils/Message.hs b/Calamity/Utils/Message.hs --- a/Calamity/Utils/Message.hs +++ b/Calamity/Utils/Message.hs @@ -1,39 +1,48 @@ -- | Things for formatting things -module Calamity.Utils.Message - ( codeblock, - codeblock', - codeline, - escapeCodeblocks, - escapeCodelines, - escapeBold, - escapeStrike, - escapeUnderline, - escapeSpoilers, - escapeFormatting, - bold, - strike, - underline, - quote, - quoteAll, - spoiler, - zws, - fmtEmoji, - displayUser, - Mentionable (..), - ) -where +module Calamity.Utils.Message ( + codeblock, + codeblock', + codeline, + escapeCodeblocks, + escapeCodelines, + escapeBold, + escapeStrike, + escapeUnderline, + escapeSpoilers, + escapeFormatting, + bold, + strike, + underline, + quote, + quoteAll, + spoiler, + zws, + fmtEmoji, + displayUser, + Mentionable (..), + asReference, +) where -import Calamity.Types.Model.Channel (Category, Channel, DMChannel, GuildChannel, TextChannel, VoiceChannel) -import Calamity.Types.Model.Guild (Emoji(..), Member, Role) +import Calamity.Types.Model.Channel ( + Category, + Channel, + DMChannel, + GuildChannel, + Message, + MessageReference(MessageReference), + TextChannel, + VoiceChannel, + ) +import Calamity.Types.Model.Guild (Emoji (..), Member, Role) import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake import Control.Lens +import Data.Foldable (Foldable (foldl')) import Data.Generics.Product.Fields import Data.Maybe (fromMaybe) import Data.String (IsString, fromString) import qualified Data.Text.Lazy as L import TextShow (TextShow (showtl)) -import Data.Foldable (Foldable(foldl')) zws :: IsString s => s zws = fromString "\x200b" @@ -66,50 +75,63 @@ escapeFormatting :: L.Text -> L.Text escapeFormatting = foldl' (.) Prelude.id [escapeCodelines, escapeCodeblocks, escapeBold, escapeStrike, escapeUnderline, escapeSpoilers, escapeFormatting] --- | Formats a lang and content into a codeblock --- --- >>> codeblock "hs" "x = y" --- "```hs\nx = y\n```" --- --- Any codeblocks in the @content@ are escaped -codeblock :: L.Text -- ^ language - -> L.Text -- ^ content - -> L.Text +{- | Formats a lang and content into a codeblock + + >>> codeblock "hs" "x = y" + "```hs\nx = y\n```" + + Any codeblocks in the @content@ are escaped +-} +codeblock :: + -- | language + L.Text -> + -- | content + L.Text -> + L.Text codeblock lang = codeblock' (Just lang) --- | Formats an optional lang and content into a codeblock --- --- Any codeblocks in the @content@ are escaped -codeblock' :: Maybe L.Text -- ^ language - -> L.Text -- ^ content - -> L.Text -codeblock' lang content = "```" <> fromMaybe "" lang <> "\n" <> - escapeCodeblocks content <> - "\n```" +{- | Formats an optional lang and content into a codeblock --- | Formats some content into a code line --- --- This always uses @``@ code lines as they can be escaped --- --- Any code lines in the content are escaped + Any codeblocks in the @content@ are escaped +-} +codeblock' :: + -- | language + Maybe L.Text -> + -- | content + L.Text -> + L.Text +codeblock' lang content = + "```" <> fromMaybe "" lang <> "\n" + <> escapeCodeblocks content + <> "\n```" + +{- | Formats some content into a code line + + This always uses @``@ code lines as they can be escaped + + Any code lines in the content are escaped +-} codeline :: L.Text -> L.Text codeline content = "``" <> escapeCodelines content <> "``" --- | Formats some text into it's bolded form --- --- Any existing bolded text is escaped +{- | Formats some text into it's bolded form + + Any existing bolded text is escaped +-} bold :: L.Text -> L.Text bold content = "**" <> escapeBold content <> "**" --- | Formats some text into it's striked form --- --- Any existing striked text is escaped +{- | Formats some text into it's striked form + + Any existing striked text is escaped +-} strike :: L.Text -> L.Text strike content = "~~" <> escapeStrike content <> "~~" --- | Formats some text into it's underlined form --- --- Any existing underlined text is escaped +{- | Formats some text into it's underlined form + + Any existing underlined text is escaped +-} underline :: L.Text -> L.Text underline content = "__" <> escapeUnderline content <> "__" @@ -121,15 +143,17 @@ quoteAll :: L.Text -> L.Text quoteAll = (">> " <>) --- | Formats some text into it's spoilered form --- --- Any existing spoilers are escaped +{- | Formats some text into it's spoilered form + + Any existing spoilers are escaped +-} spoiler :: L.Text -> L.Text spoiler content = "||" <> escapeSpoilers content <> "||" fmtEmoji :: Emoji -> L.Text -fmtEmoji Emoji { id, name, animated } = "<" <> ifanim <> ":" <> name <> ":" <> showtl id <> ">" - where ifanim = if animated then "a" else "" +fmtEmoji Emoji{id, name, animated} = "<" <> ifanim <> ":" <> name <> ":" <> showtl id <> ">" + where + ifanim = if animated then "a" else "" -- | Format a 'User' or 'Member' into the format of @username#discriminator@ displayUser :: (HasField' "username" a L.Text, HasField' "discriminator" a L.Text) => a -> L.Text @@ -195,3 +219,16 @@ instance Mentionable Role where mention = mentionSnowflake "@&" . getID @Role + +-- | Turn a regular 'Message' into a 'MessageReference' +asReference :: Message + -- ^ The message to reply to + -> Bool + -- ^ If discord should error when replying to deleted messages + -> MessageReference +asReference msg failIfNotExists = + MessageReference + (Just $ getID @Message msg) + (Just $ getID @Channel msg) + (msg ^. #guildID) + failIfNotExists diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # Changelog for Calamity +## 0.1.28.0 + ++ Added support for message types 19 (reply) and 20 (application command) ++ Added the `MessageReference` type ++ Changed the type of `Message.webhookID` to `Snowflake Webhook` ++ Added the `activity`, `application`, `messageReference`, `flags`, `stickers`, + `referencedMessage`, and `interaction` fields to messages. ++ Added `messageReference` as a parameter of `CreateMessageOptions` ++ Added `repliedUser` as a parameter of `AllowedMentions` ++ Fixed `CreateMessage` not actually sending the `allowedMentions` key ++ Added the `CrosspostMessage` route ++ Added a `ToMessage` instance for `MessageReference` ++ Added a `reply` function to `Calamity.Types.Tellable` that replies to a given + message in the same channel as the message ++ Added an `asReference` function to `Calamity.Utils.Message` + ## 0.1.27.0 + Change the structure of `Reaction` to be `(count, me, emoji)` 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: 40f996e3e284d2ed02f53b7bd8da0fa83fe1e3c156c0d0f71a46cc4afab91437 +-- hash: 3c5b52b22636e00ca4b9cc43f1349fce19deee44cd599e47312642322256f9ab name: calamity -version: 0.1.27.0 +version: 0.1.28.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web