calamity 0.1.13.0 → 0.1.14.0

raw patch · 13 files changed

+320/−32 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• calamity.cabal +3/−2
• src/Calamity/Client/Client.hs +8/−4
• src/Calamity/Commands/Parser.hs +25/−1
• src/Calamity/HTTP/Channel.hs +8/−0
• src/Calamity/Internal/AesonThings.hs +16/−4
• src/Calamity/Types/Model/Channel/Message.hs +1/−1
• src/Calamity/Types/Model/Channel/UpdatedMessage.hs +1/−1
• src/Calamity/Types/Model/Guild/Member.hs +23/−16
• src/Calamity/Types/Snowflake.hs +2/−3
• src/Calamity/Types/Tellable.hs +21/−0
• src/Calamity/Utils.hs +2/−0
• src/Calamity/Utils/Message.hs +196/−0

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

@@ -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 <https://github.com/nitros12/calamity#readme> 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

@@ -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 }) =

@@ -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 . (== ':')))

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

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

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

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

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

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

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

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

@@ -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 @\`\<zws\>\`\<zws\>\`@+escapeCodeblocks :: L.Text -> L.Text+escapeCodeblocks = L.replace "```" (L.intercalate zws $ replicate 3 "`")++-- | Replaces all occurences of @\`\`@ with @\`\<zws\>\`@+escapeCodelines :: L.Text -> L.Text+escapeCodelines = L.replace "``" (L.intercalate zws $ replicate 2 "`")++-- | Replaces all occurences of @\*\*@ with @\*\<zws\>\*@+escapeBold :: L.Text -> L.Text+escapeBold = L.replace "**" (L.intercalate zws $ replicate 2 "*")++-- | Replaces all occurences of @\~\~@ with @\~\<zws\>\~@+escapeStrike :: L.Text -> L.Text+escapeStrike = L.replace "~~" (L.intercalate zws $ replicate 2 "~")++-- | Replaces all occurences of @\_\_@ with @\_\<zws\>\_@+escapeUnderline :: L.Text -> L.Text+escapeUnderline = L.replace "__" (L.intercalate zws $ replicate 2 "_")++-- | Replaces all occurences of @\|\|@ with @\|\<zws\>\|@+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