calamity 0.1.27.0 → 0.1.28.0

raw patch · 9 files changed

+309/−164 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Calamity/HTTP/Channel.hs +16/−3
• Calamity/Internal/AesonThings.hs +6/−0
• Calamity/Types/Model/Channel.hs +1/−1
• Calamity/Types/Model/Channel/Message.hs +86/−49
• Calamity/Types/Model/Channel/Message.hs-boot +7/−1
• Calamity/Types/Tellable.hs +75/−45
• Calamity/Utils/Message.hs +100/−63
• ChangeLog.md +16/−0
• calamity.cabal +2/−2

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)`

@@ -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 <https://github.com/simmsb/calamity#readme> category:       Network, Web