diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,19 @@ # Changelog for Calamity +## 0.1.14.0 + +*2020-06-08* + +* Unpacked the `user` field of `Member` into itself. + +* Add message formatting utilities (`Calamity.Utils.Message`). + +* Add support for allowed mentions in `Tellable`. + +* Change Snowflake's show instance to just show the numberic id. + +* Added parsers for RawEmoji and Either. + ## 0.1.13.0 *2020-06-06* 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: 81cfbc5822a563275b09910155612968095794467d65ba95f1eaa54d90312085 +-- hash: d770f5d135638e3a804e22c7d2f45e4b065401028478fe7cff6ccc542244ca35 name: calamity -version: 0.1.13.0 +version: 0.1.14.0 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -127,6 +127,7 @@ Calamity.Types.Upgradeable Calamity.Utils Calamity.Utils.Colour + Calamity.Utils.Message Calamity.Utils.Permissions other-modules: Paths_calamity diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -30,6 +30,7 @@ import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.Presence ( Presence(..) ) +import Calamity.Types.Model.User import Calamity.Types.Snowflake import Calamity.Types.Token @@ -43,6 +44,7 @@ import Data.Default.Class import Data.Dynamic import Data.Foldable +import Data.Generics.Product.Subtype import Data.IORef import Data.Maybe import Data.Proxy @@ -541,8 +543,10 @@ updateCache evt Just newGuild <- getGuild guildID Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID) - let userUpdates = if oldMember ^. #user /= newMember ^. #user - then map ($ ((oldMember ^. #user), (newMember ^. #user))) (getEventHandlers @'UserUpdateEvt eh) + let oldUser :: User = upcast oldMember + newUser :: User = upcast newMember + userUpdates = if oldUser /= newUser + then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh) else mempty pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) @@ -593,7 +597,7 @@ isNew <- isUnavailableGuild (getID guild) when isNew $ delUnavailableGuild (getID guild) setGuild guild - for_ (SM.fromList (guild ^.. #members . traverse . #user)) setUser + for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser updateCache (GuildUpdate guild) = updateGuild (getID guild) (update guild) @@ -607,7 +611,7 @@ updateGuild guildID (#emojis .~ SM.fromList emojis) updateCache (GuildMemberAdd member) = do - setUser (member ^. #user) + setUser (member ^. super) updateGuild (getID member) (#members . at (getID member) ?~ member) updateCache (GuildMemberRemove GuildMemberRemoveData { guildID, user }) = diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs --- a/src/Calamity/Commands/Parser.hs +++ b/src/Calamity/Commands/Parser.hs @@ -9,9 +9,10 @@ import Calamity.Cache.Eff import Calamity.Commands.Context import Calamity.Types.Model.Channel ( Channel, GuildChannel ) -import Calamity.Types.Model.Guild ( Emoji, Guild, Member, Role ) +import Calamity.Types.Model.Guild ( Emoji, RawEmoji(..), Partial(PartialEmoji), Guild, Member, Role ) import Calamity.Types.Model.User ( User ) import Calamity.Types.Snowflake +import Calamity.Types.Partial import Control.Lens hiding ( Context ) import Control.Monad @@ -101,6 +102,17 @@ parse = P.catch (Just <$> parse @a) (const $ pure Nothing) + +instance (Parser a r, Parser b r) => Parser (Either a b) r where + type ParserResult (Either a b) = Either (ParserResult a) (ParserResult b) + + parse = do + l <- parse @(Maybe a) @r + case l of + Just l' -> pure (Left l') + Nothing -> + Right <$> parse @b @r + instance Parser a r => Parser [a] r where type ParserResult [a] = [ParserResult a] @@ -244,6 +256,10 @@ ctx <- P.ask pure $ ctx ^? #guild . _Just . #emojis . ix eid) +instance Parser RawEmoji r where + parse = parseMP (parserName @RawEmoji) (try parseCustomEmoji <|> (UnicodeEmoji <$> takeP (Just "A unicode emoji") 1)) + where parseCustomEmoji = CustomEmoji <$> partialEmoji + instance (Parser a r, Parser b r) => Parser (a, b) r where type ParserResult (a, b) = (ParserResult a, ParserResult b) @@ -270,6 +286,14 @@ snowflake :: MonadParsec e L.Text m => m (Snowflake a) snowflake = (Snowflake . read) <$> some digitChar + +partialEmoji :: MonadParsec e L.Text m => m (Partial Emoji) +partialEmoji = do + void (chunk "<" *> optional (chunk "a")) + name <- between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") $ not . (== ':')) + id <- snowflake + void $ chunk ">" + pure (PartialEmoji id name) emoji :: MonadParsec e L.Text m => m (Snowflake a) emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':'))) 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 @@ -3,6 +3,8 @@ ( ChannelRequest(..) , CreateMessageOptions(..) , ChannelUpdate(..) + , AllowedMentionType(..) + , AllowedMentions(..) , ChannelMessagesQuery(..) , GetReactionsOptions(..) , CreateChannelInviteOptions(..) @@ -61,6 +63,12 @@ deriving ( Show, Generic, Default ) deriving ( ToJSON ) via CalamityJSON AllowedMentions +instance Semigroup AllowedMentions where + AllowedMentions p0 r0 u0 <> AllowedMentions p1 r1 u1 = + AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1) + +instance Monoid AllowedMentions where + mempty = def data CreateMessageJson = CreateMessageJson { content :: Maybe Text diff --git a/src/Calamity/Internal/AesonThings.hs b/src/Calamity/Internal/AesonThings.hs --- a/src/Calamity/Internal/AesonThings.hs +++ b/src/Calamity/Internal/AesonThings.hs @@ -4,6 +4,7 @@ , type IfNoneThen , type ExtractField , type ExtractFields + , type ExtractArrayField , type InjectID , SpecialRule , DefaultToEmptyArray @@ -27,6 +28,7 @@ import GHC.Generics import qualified GHC.TypeLits as TL import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) +import Control.Monad ((>=>)) textSymbolVal :: forall n. KnownSymbol n => Proxy n -> Text textSymbolVal _ = symbolVal @n Proxy ^. packed @@ -40,7 +42,8 @@ data SpecialRuleAction = forall d. IfNoneThen d | forall field. ExtractField field - | forall field. ExtractFields field + | forall fields. ExtractFields fields + | forall field. ExtractArrayField field | forall mn idn. InjectID idn mn type IfNoneThen label d = @@ -49,9 +52,12 @@ type ExtractField label field = SpecialRule label ('ExtractField field) -type ExtractFields label field = - SpecialRule label ('ExtractFields field) +type ExtractFields label fields = + SpecialRule label ('ExtractFields fields) +type ExtractArrayField label field = + SpecialRule label ('ExtractArrayField field) + type InjectID label mn idn = SpecialRule label ('InjectID mn idn) @@ -67,7 +73,13 @@ runAction _ o = withObject (("extracting field " <> textSymbolVal @field Proxy) ^. unpacked) (.: textSymbolVal @field Proxy) o -instance (KnownSymbol field) => PerformAction ('ExtractFields field) where +instance PerformAction ('ExtractFields '[]) where + runAction _ = pure + +instance (KnownSymbol field, PerformAction ('ExtractFields fields)) => PerformAction ('ExtractFields (field : fields)) where + runAction _ = runAction (Proxy @('ExtractField field)) >=> runAction (Proxy @('ExtractFields fields)) + +instance KnownSymbol field => PerformAction ('ExtractArrayField field) where runAction _ Null = pure Null runAction _ o = withArray (("extracting fields " <> textSymbolVal @field Proxy) ^. unpacked) ((Array <$>) . traverse (withObject "extracting field" (.: textSymbolVal @field Proxy))) o diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs --- a/src/Calamity/Types/Model/Channel/Message.hs +++ b/src/Calamity/Types/Model/Channel/Message.hs @@ -47,7 +47,7 @@ deriving ( TextShow ) via TSG.FromGeneric Message deriving ( ToJSON ) via CalamityJSON Message deriving ( FromJSON ) via WithSpecialCases - '["author" `ExtractField` "id", "mentions" `ExtractFields` "id", + '["author" `ExtractField` "id", "mentions" `ExtractArrayField` "id", "reactions" `IfNoneThen` DefaultToEmptyArray] Message deriving ( HasID Message ) via HasIDField "id" Message diff --git a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs --- a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs +++ b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs @@ -37,7 +37,7 @@ deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric UpdatedMessage deriving ( FromJSON ) via WithSpecialCases - '["author" `ExtractField` "id", "mentions" `ExtractFields` "id"] + '["author" `ExtractField` "id", "mentions" `ExtractArrayField` "id"] UpdatedMessage deriving ( HasID Message ) via HasIDField "id" UpdatedMessage deriving ( HasID Channel ) via HasIDField "channelID" UpdatedMessage diff --git a/src/Calamity/Types/Model/Guild/Member.hs b/src/Calamity/Types/Model/Guild/Member.hs --- a/src/Calamity/Types/Model/Guild/Member.hs +++ b/src/Calamity/Types/Model/Guild/Member.hs @@ -9,10 +9,8 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.Lens import Data.Aeson -import Data.Generics.Product.Fields import Data.Text.Lazy ( Text ) import Data.Time import Data.Vector.Unboxed ( Vector ) @@ -21,23 +19,32 @@ import TextShow import qualified TextShow.Generic as TSG +import Data.Word (Word64) data Member = Member - { user :: User - , guildID :: Snowflake Guild - , nick :: Maybe Text - , roles :: Vector (Snowflake Role) - , joinedAt :: UTCTime - , deaf :: Bool - , mute :: Bool + { id :: Snowflake User + , username :: Text + , discriminator :: Text + , bot :: Maybe Bool + , avatar :: Maybe Text + , mfaEnabled :: Maybe Bool + , verified :: Maybe Bool + , email :: Maybe Text + , flags :: Maybe Word64 + , premiumType :: Maybe Word64 + , guildID :: Snowflake Guild + , nick :: Maybe Text + , roles :: Vector (Snowflake Role) + , joinedAt :: UTCTime + , deaf :: Bool + , mute :: Bool } deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric Member - deriving ( ToJSON, FromJSON ) via CalamityJSON Member + deriving ( FromJSON ) via WithSpecialCases '[ + "user" `ExtractFields` ["id", "username", "discriminator", + "bot", "avatar", "mfa_enabled", + "verified", "email", "flags", "premium_type"]] Member deriving ( HasID Guild ) via HasIDField "guildID" Member - -instance HasID User Member where - getID = getID . (^. field @"user") - -instance HasID Member Member where - getID = coerceSnowflake . getID @User + deriving ( HasID Member ) via HasIDFieldCoerce "id" Member User + deriving ( HasID User ) via HasIDField "id" Member diff --git a/src/Calamity/Types/Snowflake.hs b/src/Calamity/Types/Snowflake.hs --- a/src/Calamity/Types/Snowflake.hs +++ b/src/Calamity/Types/Snowflake.hs @@ -26,15 +26,14 @@ import GHC.Generics import TextShow -import qualified TextShow.Generic as TSG -- Thanks sbrg -- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78 newtype Snowflake (t :: Type) = Snowflake { fromSnowflake :: Word64 } - deriving ( Generic, Show, Eq, Ord, Data ) - deriving ( TextShow ) via TSG.FromGeneric (Snowflake t) + deriving ( Generic, Eq, Ord, Data ) + deriving ( Show, TextShow ) via Word64 deriving newtype ( NFData, ToJSONKey, Hashable ) instance ToJSON (Snowflake t) where diff --git a/src/Calamity/Types/Tellable.hs b/src/Calamity/Types/Tellable.hs --- a/src/Calamity/Types/Tellable.hs +++ b/src/Calamity/Types/Tellable.hs @@ -3,6 +3,7 @@ ( ToMessage(..) , Tellable(..) , TFile(..) + , TMention(..) , tell ) where import Calamity.Client.Types @@ -29,6 +30,10 @@ newtype TFile = TFile ByteString deriving ( Show, Generic ) +-- | A wrapper type for allowing mentions +newtype TMention a = TMention (Snowflake a) + deriving ( Show, Generic ) + -- | Things that can be used to send a message -- -- Can be used to compose text, embeds, and files. /e.g./ @@ -59,6 +64,22 @@ -- | Message file, '(<>)' keeps the last added file instance ToMessage TFile where intoMsg (TFile f) = Endo (#file %~ getLast . (<> Last (Just f)) . Last) + +-- | Allowed mentions, '(<>)' combines allowed mentions +instance ToMessage AllowedMentions where + intoMsg m = Endo (#allowedMentions %~ (<> Just m)) + +-- | Add a 'User' id to the list of allowed user mentions +instance ToMessage (TMention User) where + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [s]) + +-- | Add a 'Member' id to the list of allowed user mentions +instance ToMessage (TMention Member) where + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [coerceSnowflake s]) + +-- | Add a 'Role' id to the list of allowed role mentions +instance ToMessage (TMention Role) where + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles <>~ [s]) instance ToMessage (Endo CreateMessageOptions) where intoMsg = Prelude.id diff --git a/src/Calamity/Utils.hs b/src/Calamity/Utils.hs --- a/src/Calamity/Utils.hs +++ b/src/Calamity/Utils.hs @@ -1,7 +1,9 @@ -- | Useful things module Calamity.Utils ( module Calamity.Utils.Permissions + , module Calamity.Utils.Message , module Calamity.Utils.Colour ) where import Calamity.Utils.Colour +import Calamity.Utils.Message import Calamity.Utils.Permissions diff --git a/src/Calamity/Utils/Message.hs b/src/Calamity/Utils/Message.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Utils/Message.hs @@ -0,0 +1,196 @@ +-- | 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 + +import Calamity.Types.Model.Channel (Category, Channel, DMChannel, GuildChannel, 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.Generics.Product.Fields +import Data.Maybe (fromMaybe) +import Data.String (IsString, fromString) +import qualified Data.Text.Lazy as L +import TextShow (TextShow (showtl)) + +zws :: IsString s => s +zws = fromString "\x200b" + +-- | Replaces all occurences of @\`\`\`@ with @\`\\`\\`@ +escapeCodeblocks :: L.Text -> L.Text +escapeCodeblocks = L.replace "```" (L.intercalate zws $ replicate 3 "`") + +-- | Replaces all occurences of @\`\`@ with @\`\\`@ +escapeCodelines :: L.Text -> L.Text +escapeCodelines = L.replace "``" (L.intercalate zws $ replicate 2 "`") + +-- | Replaces all occurences of @\*\*@ with @\*\\*@ +escapeBold :: L.Text -> L.Text +escapeBold = L.replace "**" (L.intercalate zws $ replicate 2 "*") + +-- | Replaces all occurences of @\~\~@ with @\~\\~@ +escapeStrike :: L.Text -> L.Text +escapeStrike = L.replace "~~" (L.intercalate zws $ replicate 2 "~") + +-- | Replaces all occurences of @\_\_@ with @\_\\_@ +escapeUnderline :: L.Text -> L.Text +escapeUnderline = L.replace "__" (L.intercalate zws $ replicate 2 "_") + +-- | Replaces all occurences of @\|\|@ with @\|\\|@ +escapeSpoilers :: L.Text -> L.Text +escapeSpoilers = L.replace "||" (L.intercalate zws $ replicate 2 "|") + +-- | Escape all discord formatting +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 +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 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 +bold :: L.Text -> L.Text +bold content = "**" <> escapeBold content <> "**" + +-- | 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 +underline :: L.Text -> L.Text +underline content = "__" <> escapeUnderline content <> "__" + +-- | Quotes a section of text +quote :: L.Text -> L.Text +quote = ("> " <>) + +-- | Quotes all remaining text +quoteAll :: L.Text -> L.Text +quoteAll = (">> " <>) + +-- | 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 "" + +-- | 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 +displayUser u = (u ^. field' @"username") <> "#" <> (u ^. field' @"discriminator") + +mentionSnowflake :: L.Text -> Snowflake a -> L.Text +mentionSnowflake tag s = "<" <> tag <> showtl s <> ">" + +-- | Things that can be mentioned +class Mentionable a where + mention :: a -> L.Text + +instance Mentionable (Snowflake User) where + mention = mentionSnowflake "@" + +instance Mentionable (Snowflake Member) where + mention = mentionSnowflake "@" + +instance Mentionable (Snowflake Channel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake TextChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake VoiceChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake Category) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake GuildChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake DMChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake Role) where + mention = mentionSnowflake "@&" + +instance Mentionable User where + mention = mentionSnowflake "@" . getID @User + +instance Mentionable Member where + mention = mentionSnowflake "@" . getID @Member + +instance Mentionable Channel where + mention = mentionSnowflake "#" . getID @Channel + +instance Mentionable TextChannel where + mention = mentionSnowflake "#" . getID @TextChannel + +instance Mentionable VoiceChannel where + mention = mentionSnowflake "#" . getID @VoiceChannel + +instance Mentionable Category where + mention = mentionSnowflake "#" . getID @Category + +instance Mentionable GuildChannel where + mention = mentionSnowflake "#" . getID @GuildChannel + +instance Mentionable DMChannel where + mention = mentionSnowflake "#" . getID @DMChannel + +instance Mentionable Role where + mention = mentionSnowflake "@&" . getID @Role