calamity 0.6.0.0 → 0.7.0.0

raw patch · 23 files changed

+408/−86 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Calamity/Client/Client.hs +6/−6
• Calamity/Client/ShardManager.hs +2/−1
• Calamity/Gateway/Shard.hs +9/−9
• Calamity/HTTP/Channel.hs +1/−1
• Calamity/HTTP/Interaction.hs +5/−5
• Calamity/HTTP/Internal/Ratelimit.hs +6/−6
• Calamity/HTTP/Webhook.hs +1/−1
• Calamity/Internal/Updateable.hs +3/−1
• Calamity/Types.hs +35/−25
• Calamity/Types/CDNAsset.hs +30/−0
• Calamity/Types/Model.hs +4/−0
• Calamity/Types/Model/Avatar.hs +47/−0
• Calamity/Types/Model/Guild/Emoji.hs +8/−0
• Calamity/Types/Model/Guild/Emoji.hs-boot +13/−0
• Calamity/Types/Model/Guild/Guild.hs +84/−16
• Calamity/Types/Model/Guild/Member.hs +23/−4
• Calamity/Types/Model/Guild/Role.hs +29/−4
• Calamity/Types/Model/User.hs +39/−5
• Calamity/Types/Model/User.hs-boot +8/−0
• Calamity/Types/Snowflake.hs +2/−0
• Calamity/Utils/CDNUrl.hs +22/−0
• ChangeLog.md +26/−0
• calamity.cabal +5/−2

@@ -406,11 +406,11 @@   r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m   case r of     Right _ -> pure ()-    Left e -> debug [fmt|got exception: {e:s}|]+    Left e -> debug . T.pack $ "got exception: " <> show e  handleEvent :: BotC r => Int -> DispatchData -> P.Sem r () handleEvent shardID data' = do-  debug [fmt|"handling an event: {ctorName data'}"|]+  debug . T.pack $ "handling an event: " <> ctorName data'   eventHandlers <- P.atomicGet   actions <- P.runFail $ do     evtCounter <- registerCounter "events_received" [("type", T.pack $ ctorName data'), ("shard", showt shardID)]@@ -427,7 +427,7 @@       (time, _) <- timeA . catchAllLogging $ P.embed action       void $ observeHistogram time eventHandleHisto     -- pattern match failures are usually stuff like events for uncached guilds, etc-    Left err -> debug [fmt|Failed handling actions for event: {err:s}|]+    Left err -> debug . T.pack $ "Failed handling actions for event: " <> show err  handleEvent' ::   BotC r =>@@ -711,10 +711,10 @@   updateGuild guildID (#roles %~ SM.insert role) updateCache (GuildRoleDelete GuildRoleDeleteData {guildID, roleID}) =   updateGuild guildID (#roles %~ sans roleID)-updateCache (MessageCreate !msg !_ !_) =+updateCache (MessageCreate !msg !user !_) = do   setMessage msg--- I think it's for the best not to cache things here, instead the end user--- can just cache manually which users and members they want+  whenJust user $ \u ->+    setUser u updateCache (MessageUpdate msg !_ !_) =   updateMessage (getID msg) (update msg) updateCache (MessageDelete MessageDeleteData {id}) = delMessage id

@@ -8,6 +8,7 @@ import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Monad+import qualified Data.Text as T import Data.Traversable import Optics import Polysemy (Sem)@@ -38,7 +39,7 @@   let host = gateway ^. #url   P.embed $ putMVar numShardsVar numShards' -  info [fmt|Number of shards: {numShards'}|]+  info . T.pack $ "Number of shards: " <> show numShards'    shards <- for [0 .. numShards' - 1] $ \id ->     newShard host id numShards' token initialStatus intents inc

@@ -123,7 +123,7 @@    -- We have to do this all ourself I think?   -- TODO: see if this isn't needed-  let logExc e = debug [fmt|runWebsocket raised with {e:s}|]+  let logExc e = debug $ "runWebsocket raised with " <> (T.pack . show $ e)   logExc' <- bindSemToIO logExc   let handler e = do         void $ logExc' e@@ -186,7 +186,7 @@   case wsConn' of     Just wsConn -> do       let encodedData = A.encode data'-      debug [fmt|sending {data':s} encoded to {encodedData:s} to gateway|]+      debug . T.pack $ "sending " <> show data' <> " encoded to " <> show encodedData <> " to gateway"       P.embed . sendTextData wsConn $ encodedData     Nothing -> debug "tried to send to closed WS" @@ -237,7 +237,7 @@            case msg of             Left (c, reason) -> do-              whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|])+              whenJust reason (\r -> error . T.pack $ "Shard closed with reason: " <> show r)               P.embed . atomically $ writeTBMQueue outqueue (Control c)             Right msg' -> do               -- debug [fmt|Got msg: {msg'}|]@@ -246,7 +246,7 @@                 Right a ->                   P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a)                 Left e -> do-                  error [fmt|Failed to decode {e}: {msg'}|]+                  error . T.pack $ "Failed to decode " <> e <> ": "<> show msg'                   pure True               when r inner     outerloop :: ShardC r => Sem r ()@@ -254,7 +254,7 @@       shard :: Shard <- P.atomicGets (^. #shardS)       let host = shard ^. #gateway       let host' = fromMaybe host $ T.stripPrefix "wss://" host-      info [fmt|starting up shard {shardID shard} of {shardCount shard}|]+      info . T.pack $ "starting up shard " <> show (shardID shard) <> " of " <> show (shardCount shard)        innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop @@ -284,7 +284,7 @@        case (seqNum', sessionID') of         (Just n, Just s) -> do-          debug [fmt|Resuming shard (sessionID: {s}, seq: {n})|]+          debug $ "Resuming shard (sessionID: " <> s <> ", seq: " <> T.pack (show n)           sendToWs             ( Resume                 ResumeData@@ -362,14 +362,14 @@             P.embed $ threadDelay (15 * 1000 * 1000)         P.throw ShardFlowRestart       Hello interval -> do-        info [fmt|Received hello, beginning to heartbeat at an interval of {interval}ms|]+        info . T.pack $ "Received hello, beginning to heartbeat at an interval of " <> show interval <> "ms"         startHeartBeatLoop interval       HeartBeatAck -> do         debug "Received heartbeat ack"         P.atomicModify' (#hbResponse .~ True)     handleMsg (Control msg) = case msg of       SendPresence data' -> do-        debug [fmt|Sending presence: ({data':s})|]+        debug . T.pack $ "Sending presence: (" <> show data' <> ")"         sendToWs $ StatusUpdate data'       RestartShard -> P.throw ShardFlowRestart       ShutDownShard -> P.throw ShardFlowShutDown@@ -395,7 +395,7 @@ sendHeartBeat :: ShardC r => Sem r () sendHeartBeat = do   sn <- P.atomicGets (^. #seqNum)-  debug [fmt|Sending heartbeat (seq: {sn:s})|]+  debug . T.pack $ "Sending heartbeat (seq: " <> show sn <> ")"   sendToWs $ HeartBeat sn   P.atomicModify' (#hbResponse .~ False) 

@@ -418,7 +418,7 @@       & buildRoute   action (CreateMessage _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }

@@ -324,7 +324,7 @@      in postWith' (ReqBodyJson jsonBody)   action (CreateResponseMessage _ _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }@@ -354,7 +354,7 @@     postWith' body u o   action (CreateResponseUpdate _ _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }@@ -399,7 +399,7 @@   action (GetOriginalInteractionResponse _ _) = getWith   action (EditOriginalInteractionResponse _ _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }@@ -430,7 +430,7 @@   action (DeleteOriginalInteractionResponse _ _) = deleteWith   action (CreateFollowupMessage _ _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }@@ -456,7 +456,7 @@   action GetFollowupMessage {} = getWith   action (EditFollowupMessage _ _ _ cm) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }

@@ -210,7 +210,7 @@       if           | statusIsSuccessful status -> do             let resp = responseBody r'-            debug [fmt|Got good response from discord: {status:s}|]+            debug $ "Got good response from discord: " <> (T.pack . show $ status)             now <- P.embed getCurrentTime             let rlHeaders = buildBucketState now r'             pure $ Good resp rlHeaders@@ -224,13 +224,13 @@                 pure $ ServerError (statusCode status)           | statusIsClientError status -> do             let err = responseBody r'-            error [fmt|Something went wrong: {err:s}, response: {r':s}|]+            error . T.pack $ ("Something went wrong: " <> show err <> ", response: " <> show r')             pure $ ClientError (statusCode status) err           | otherwise -> do-            debug [fmt|Got server error from discord: {statusCode status}|]+            debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status)             pure $ ServerError (statusCode status)     Left e -> do-      error [fmt|Something went wrong with the http client: {e}|]+      error . T.pack $ "Something went wrong with the http client: " <> e       pure . InternalResponseError $ T.pack e  -- | Parse a ratelimit header returning when it unlocks@@ -286,7 +286,7 @@       res <- action       case res of         Retry r | numRetries > maxRetries -> do-          debug [fmt|Request failed after {maxRetries} retries|]+          debug . T.pack $ "Request failed after " <> show maxRetries <> " retries"           pure $ Left r         Retry _ ->           retryInner (numRetries + 1)@@ -344,7 +344,7 @@           Nothing -> pure ()       pure $ RGood v     Ratelimited unlockWhen False (Just (bs, bk)) -> do-      debug [fmt|429 ratelimited on route, retrying at {unlockWhen:s}|]+      debug . T.pack $ "429 ratelimited on route, retrying at " <> show unlockWhen        P.embed . atomically $ do         case rl of

@@ -183,7 +183,7 @@   action (DeleteWebhookToken _ _) = deleteWith   action (ExecuteWebhook _ _ wh) = \u o -> do     let filePart CreateMessageAttachment {filename, content} n =-          (partLBS @IO [fmt|files[{n}]|] content)+          (partLBS @IO (T.pack $ "files[" <> show n <> "]") content)             { partFilename = Just (T.unpack filename)             , partContentType = Just (defaultMimeLookup filename)             }

@@ -110,6 +110,8 @@       & setF @"name" n       & setF @"icon" n       & setF @"splash" n+      & setF @"discoverySplash" n+      & setF @"banner" n       & setF @"owner" n       & setF @"ownerID" n       & mergeF @"permissions" n@@ -135,7 +137,7 @@       & setF @"username" n       & setF @"discriminator" n       & mergeF' @"bot" n-      & mergeF' @"avatar" n+      & setF @"avatar" n       & mergeF' @"mfaEnabled" n       & mergeF' @"verified" n       & mergeF' @"email" n

@@ -1,28 +1,38 @@ -- | All user facing types-module Calamity.Types-    ( module Calamity.Types.Model-    , module Calamity.Types.Partial-    , module Calamity.Types.Snowflake-    , module Calamity.Types.Token-    , module Calamity.Types.Tellable-    , module Calamity.Types.Upgradeable-    -- * Types-    -- $typesDocs-    ) where+module Calamity.Types (+  module Calamity.Types.Model,+  module Calamity.Types.Partial,+  module Calamity.Types.Snowflake,+  module Calamity.Types.Token,+  module Calamity.Types.Tellable,+  module Calamity.Types.Upgradeable,+  module Calamity.Types.CDNAsset,+  module Calamity.Types.TokenEff,+  module Calamity.Types.LogEff, -import           Calamity.Types.Model-import           Calamity.Types.Partial-import           Calamity.Types.Snowflake-import           Calamity.Types.Token-import           Calamity.Types.Tellable-import           Calamity.Types.Upgradeable+  -- * Types+  -- $typesDocs+) where --- $typesDocs------ This module collects all discord models, and other useful types together.------ The 'Tellable' class allows you to construct and send--- messages to things to you can send messages to in a neat way.------ The 'Upgradeable' class allows you to upgrade a snowflake to the full value--- it refers to.+import Calamity.Types.CDNAsset+import Calamity.Types.LogEff+import Calamity.Types.Model+import Calamity.Types.Partial+import Calamity.Types.Snowflake+import Calamity.Types.Tellable+import Calamity.Types.Token+import Calamity.Types.TokenEff+import Calamity.Types.Upgradeable++{- $typesDocs++ This module collects all discord models, and other useful types together.++ The 'Tellable' class allows you to construct and send+ messages to things to you can send messages to in a neat way.++ The 'Upgradeable' class allows you to upgrade a snowflake to the full value+ it refers to.++ The 'CDNAsset' class allows you to fetch assets from the discord CDN.+-}

@@ -0,0 +1,30 @@+-- | Things that can be fetched from the discord CDN+module Calamity.Types.CDNAsset (+  CDNAsset (..),+  fetchAsset,+  fetchAsset',+) where++import qualified Control.Exception.Safe as Ex+import Data.ByteString.Lazy (LazyByteString)+import qualified Network.HTTP.Req as Req+import qualified Polysemy as P++-- | Retrieve the asset from the CDN, like 'fetchAsset' but gives you more control+fetchAsset' :: (CDNAsset a, Req.MonadHttp m) => a -> m LazyByteString+fetchAsset' a = Req.responseBody <$> Req.req Req.GET (assetURL a) Req.NoReqBody Req.lbsResponse mempty++-- | Retrieve the asset from the CDN+fetchAsset :: (CDNAsset a, P.Member (P.Embed IO) r) => a -> P.Sem r (Either Req.HttpException LazyByteString)+fetchAsset a = P.embed $ Ex.catch (Right <$> r) (\(e :: Req.HttpException) -> pure $ Left e)+  where+    r = Req.runReq reqConfig $ fetchAsset' a++reqConfig :: Req.HttpConfig+reqConfig =+  Req.defaultHttpConfig+    { Req.httpConfigCheckResponse = \_ _ _ -> Nothing+    }++class CDNAsset a where+  assetURL :: a -> Req.Url 'Req.Https

@@ -5,10 +5,14 @@   module Calamity.Types.Model.Presence,   module Calamity.Types.Model.User,   module Calamity.Types.Model.Voice,+  module Calamity.Types.Model.Avatar,+  module Calamity.Types.Model.Interaction, ) where +import Calamity.Types.Model.Avatar import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild+import Calamity.Types.Model.Interaction import Calamity.Types.Model.Presence import Calamity.Types.Model.User import Calamity.Types.Model.Voice

@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}++module Calamity.Types.Model.Avatar (+  Avatar (..),+  MemberAvatar (..),+) where++import Calamity.Types.CDNAsset (CDNAsset (..))+import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild+import {-# SOURCE #-} Calamity.Types.Model.User+import Calamity.Types.Snowflake (Snowflake, fromSnowflake)+import Calamity.Utils.CDNUrl (assetHashFile, cdnURL)+import qualified Data.Text as T+import Network.HTTP.Req ((/:), (/~))+import Optics (makeFieldLabelsNoPrefix)+import TextShow (showt)+import TextShow.TH (deriveTextShow)++data Avatar = Avatar+  { hash :: Maybe T.Text+  , userID :: Snowflake User+  , discrim :: Int+  }+  deriving (Show, Eq)++instance CDNAsset Avatar where+  assetURL Avatar {hash = Just h, userID} =+    cdnURL /: "avatars" /~ fromSnowflake userID /: assetHashFile h+  assetURL Avatar {discrim} =+    cdnURL /: "embed" /: "avatars" /: (showt (discrim `mod` 5) <> ".png")++-- | A member's custom guild avatar+data MemberAvatar = MemberAvatar+  { hash :: T.Text+  , guildID :: Snowflake Guild+  , userID :: Snowflake User+  }+  deriving (Show, Eq)++instance CDNAsset MemberAvatar where+  assetURL MemberAvatar {hash, guildID, userID} =+    cdnURL /: "guilds" /~ guildID /: "users" /~ userID /: "avatars" /: assetHashFile hash++$(deriveTextShow ''Avatar)+$(makeFieldLabelsNoPrefix ''Avatar)+$(deriveTextShow ''MemberAvatar)+$(makeFieldLabelsNoPrefix ''MemberAvatar)

@@ -14,14 +14,18 @@   CalamityToJSON' (..),   (.=),  )+import Calamity.Types.CDNAsset (CDNAsset (..)) import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake+import Calamity.Utils.CDNUrl (cdnURL) import Data.Aeson ((.!=), (.:), (.:?)) import qualified Data.Aeson as Aeson import qualified Data.Text as T import Data.Vector.Unboxing (Vector)+import Network.HTTP.Req ((/:)) import Optics.TH+import TextShow (showt) import qualified TextShow  data Emoji = Emoji@@ -47,6 +51,10 @@       <*> v .:? "require_colons" .!= False       <*> v .:? "managed" .!= False       <*> v .:? "animated" .!= False++instance CDNAsset Emoji where+  assetURL Emoji {id, animated} =+    cdnURL /: "emojis" /: (showt id <> if animated then ".gif" else ".png")  emojiAsRawEmoji :: Emoji -> RawEmoji emojiAsRawEmoji Emoji {id, name, animated} = CustomEmoji $ PartialEmoji id name animated

@@ -0,0 +1,13 @@+-- | Discord Emojis+module Calamity.Types.Model.Guild.Emoji+    ( RawEmoji+    ) where++import Data.Aeson++data RawEmoji++instance Show RawEmoji+instance Eq RawEmoji++instance FromJSON RawEmoji

@@ -3,6 +3,10 @@ -- | Discord Guilds module Calamity.Types.Model.Guild.Guild (   Guild (..),+  GuildIcon (..),+  GuildSplash (..),+  GuildDiscoverySplash (..),+  GuildBanner (..),   Partial (PartialGuild),   UpdatedGuild (..), ) where@@ -10,6 +14,7 @@ import Calamity.Internal.SnowflakeMap (SnowflakeMap) import qualified Calamity.Internal.SnowflakeMap as SM import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=))+import Calamity.Types.CDNAsset (CDNAsset (..)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji import Calamity.Types.Model.Guild.Member@@ -18,24 +23,68 @@ import Calamity.Types.Model.User import Calamity.Types.Model.Voice.VoiceState import Calamity.Types.Snowflake+import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) import Data.Aeson ((.!=), (.:), (.:?)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as LH import Data.Maybe-import Data.Text (Text)+import qualified Data.Text as T import Data.Time import Data.Word+import Network.HTTP.Req ((/:), (/~)) import Optics import qualified TextShow import TextShow.TH (deriveTextShow) +data GuildIcon = GuildIcon+  { guildID :: Snowflake Guild+  , hash :: T.Text+  }+  deriving (Show, Eq)++instance CDNAsset GuildIcon where+  assetURL GuildIcon {hash, guildID} =+    cdnURL /: "icons" /~ guildID /: assetHashFile hash++data GuildSplash = GuildSplash+  { guildID :: Snowflake Guild+  , hash :: T.Text+  }+  deriving (Show, Eq)++instance CDNAsset GuildSplash where+  assetURL GuildSplash {hash, guildID} =+    cdnURL /: "splashes" /~ guildID /: assetHashFile hash++data GuildDiscoverySplash = GuildDiscoverySplash+  { guildID :: Snowflake Guild+  , hash :: T.Text+  }+  deriving (Show, Eq)++instance CDNAsset GuildDiscoverySplash where+  assetURL GuildDiscoverySplash {hash, guildID} =+    cdnURL /: "discovery-splashes" /~ guildID /: assetHashFile hash++data GuildBanner = GuildBanner+  { guildID :: Snowflake Guild+  , hash :: T.Text+  }+  deriving (Show, Eq)++instance CDNAsset GuildBanner where+  assetURL GuildBanner {hash, guildID} =+    cdnURL /: "banners" /~ guildID /: assetHashFile hash+ data Guild = Guild   { id :: Snowflake Guild-  , name :: Text-  , icon :: Maybe Text-  , splash :: Maybe Text+  , name :: T.Text+  , icon :: Maybe GuildIcon+  , splash :: Maybe GuildSplash+  , discoverySplash :: Maybe GuildSplash+  , banner :: Maybe GuildBanner   , owner :: Maybe Bool   , ownerID :: Snowflake User   , permissions :: Word64@@ -48,7 +97,7 @@   , explicitContentFilter :: Int   , roles :: SnowflakeMap Role   , emojis :: SnowflakeMap Emoji-  , features :: [Text]+  , features :: [T.Text]   , mfaLevel :: Int   , applicationID :: Maybe (Snowflake User)   , widgetEnabled :: Bool@@ -63,7 +112,7 @@   , members :: SnowflakeMap Member   , channels :: SnowflakeMap GuildChannel   , presences :: HashMap (Snowflake User) Presence-  , preferredLocale :: Text+  , preferredLocale :: T.Text   }   deriving (Eq, Show)   deriving (TextShow.TextShow) via TextShow.FromStringShow Guild@@ -93,10 +142,17 @@           )         $ presences' +    icon <- (GuildIcon id <$>) <$> v .:? "icon"+    splash <- (GuildSplash id <$>) <$> v .:? "splash"+    discoverySplash <- (GuildSplash id <$>) <$> v .:? "discovery_splash"+    banner <- (GuildBanner id <$>) <$> v .:? "banner"+     Guild id       <$> v .: "name"-      <*> v .: "icon"-      <*> v .:? "splash"+      <*> pure icon+      <*> pure splash+      <*> pure discoverySplash+      <*> pure banner       <*> v .:? "owner"       <*> v .: "owner_id"       <*> v .:? "permissions" .!= 0@@ -127,7 +183,7 @@  data instance Partial Guild = PartialGuild   { id :: Snowflake Guild-  , name :: Text+  , name :: T.Text   }   deriving (Eq, Show)   deriving (HasID Guild) via HasIDField "id" (Partial Guild)@@ -147,9 +203,11 @@  data UpdatedGuild = UpdatedGuild   { id :: Snowflake Guild-  , name :: Text-  , icon :: Maybe Text-  , splash :: Maybe Text+  , name :: T.Text+  , icon :: Maybe GuildIcon+  , splash :: Maybe GuildSplash+  , discoverySplash :: Maybe GuildSplash+  , banner :: Maybe GuildBanner   , owner :: Maybe Bool   , ownerID :: Snowflake User   , permissions :: Maybe Word64@@ -162,13 +220,13 @@   , explicitContentFilter :: Int   , roles :: SnowflakeMap Role   , emojis :: SnowflakeMap Emoji-  , features :: [Text]+  , features :: [T.Text]   , mfaLevel :: Int   , applicationID :: Maybe (Snowflake User)   , widgetEnabled :: Maybe Bool   , widgetChannelID :: Maybe (Snowflake GuildChannel)   , systemChannelID :: Maybe (Snowflake GuildChannel)-  , preferredLocale :: Text+  , preferredLocale :: T.Text   }   deriving (Eq, Show)   deriving (TextShow.TextShow) via TextShow.FromStringShow UpdatedGuild@@ -176,11 +234,19 @@  instance Aeson.FromJSON UpdatedGuild where   parseJSON = Aeson.withObject "Guild" $ \v -> do+    id <- v .: "id"+    icon <- (GuildIcon id <$>) <$> v .:? "icon"+    splash <- (GuildSplash id <$>) <$> v .:? "splash"+    discoverySplash <- (GuildSplash id <$>) <$> v .:? "discovery_splash"+    banner <- (GuildBanner id <$>) <$> v .:? "banner"+     UpdatedGuild       <$> v .: "id"       <*> v .: "name"-      <*> v .:? "icon"-      <*> v .:? "splash"+      <*> pure icon+      <*> pure splash+      <*> pure discoverySplash+      <*> pure banner       <*> v .:? "owner"       <*> v .: "owner_id"       <*> v .:? "permissions"@@ -201,8 +267,10 @@       <*> v .:? "system_channel_id"       <*> v .: "preferred_locale" +$(deriveTextShow ''GuildIcon) $(deriveTextShow 'PartialGuild)  $(makeFieldLabelsNoPrefix ''Guild)+$(makeFieldLabelsNoPrefix ''GuildIcon) $(makeFieldLabelsNoPrefix 'PartialGuild) $(makeFieldLabelsNoPrefix ''UpdatedGuild)

@@ -3,13 +3,17 @@ -- | Guild Members module Calamity.Types.Model.Guild.Member (Member (..)) where +import Calamity.Internal.IntColour import Calamity.Internal.Utils (AesonVector (unAesonVector))+import Calamity.Types.Model.Avatar (Avatar (..)) import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake-import Data.Aeson ((.:), (.:?), (.!=))+import Data.Aeson ((.!=), (.:), (.:?)) import qualified Data.Aeson as Aeson+import Data.Colour (Colour) import Data.Text (Text)+import Data.Text.Read (decimal) import Data.Time import Data.Vector.Unboxing (Vector) import qualified Data.Vector.Unboxing as V@@ -22,8 +26,12 @@   , username :: Text   , discriminator :: Text   , bot :: Maybe Bool-  , avatar :: Maybe Text+  , avatar :: Avatar+  , memberAvatar :: Maybe Text   , mfaEnabled :: Maybe Bool+  , banner :: Maybe UserBanner+  , accentColour :: Maybe (Colour Double)+  , locale :: Maybe Text   , verified :: Maybe Bool   , email :: Maybe Text   , flags :: Maybe Word64@@ -42,14 +50,25 @@ instance Aeson.FromJSON Member where   parseJSON = Aeson.withObject "Member" $ \v -> do     u :: Aeson.Object <- v .: "user"-+    uid <- u .: "id"+    avatarHash <- u .:? "avatar"+    discrim <- u .: "discriminator"+    discrim' <- case decimal discrim of+      Right (n, _) -> pure n+      Left e -> fail e+    let avatar = Avatar avatarHash uid discrim'+    banner <- (UserBanner uid <$>) <$> v .:? "banner"     Member-      <$> u .: "id"+      <$> pure uid       <*> u .: "username"       <*> u .: "discriminator"       <*> v .:? "bot"+      <*> pure avatar       <*> v .:? "avatar"       <*> v .:? "mfa_enabled"+      <*> pure banner+      <*> (fmap fromIntColour <$> v .:? "accent_color")+      <*> v .:? "locale"       <*> v .:? "verified"       <*> v .:? "email"       <*> v .:? "flags"

@@ -1,24 +1,44 @@ {-# LANGUAGE TemplateHaskell #-}  -- | Guild roles-module Calamity.Types.Model.Guild.Role (Role (..)) where+module Calamity.Types.Model.Guild.Role (+  Role (..),+  RoleIcon (..),+) where  import Calamity.Internal.IntColour import Calamity.Internal.Utils+import Calamity.Types.CDNAsset (CDNAsset (..))+import {-# SOURCE #-} Calamity.Types.Model.Guild.Emoji import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake-import Data.Aeson ((.:))+import Calamity.Utils.CDNUrl (assetHashFile, cdnURL)+import Data.Aeson ((.:), (.:?)) import qualified Data.Aeson as Aeson import Data.Colour import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Req ((/:), (/~)) import Optics.TH import qualified TextShow +data RoleIcon = RoleIcon+  { roleID :: Snowflake Role+  , hash :: T.Text+  }+  deriving (Show, Eq)++instance CDNAsset RoleIcon where+  assetURL RoleIcon {hash, roleID} =+    cdnURL /: "icons" /~ roleID /: assetHashFile hash+ data Role = Role   { id :: Snowflake Role   , name :: Text   , color :: Colour Double   , hoist :: Bool+  , icon :: Maybe RoleIcon+  , emoji :: Maybe RawEmoji   , position :: Int   , permissions :: Permissions   , managed :: Bool@@ -41,12 +61,17 @@     ]  instance Aeson.FromJSON Role where-  parseJSON = Aeson.withObject "Role" $ \v ->+  parseJSON = Aeson.withObject "Role" $ \v -> do+    id <- v .: "id"+    icon <- (RoleIcon id <$>) <$> v .: "icon"+     Role-      <$> v .: "id"+      <$> pure id       <*> v .: "name"       <*> (fromIntColour <$> v .: "color")       <*> v .: "hoist"+      <*> pure icon+      <*> v .:? "unicode_emoji"       <*> v .: "position"       <*> v .: "permissions"       <*> v .: "managed"

@@ -3,45 +3,80 @@ -- | A User module Calamity.Types.Model.User (   User (..),+  UserBanner (..),   Partial (PartialUser),   StatusType (..), ) where +import Calamity.Internal.IntColour+import Calamity.Types.CDNAsset (CDNAsset (..))+import Calamity.Types.Model.Avatar import {-# SOURCE #-} Calamity.Types.Model.Guild.Member import Calamity.Types.Partial import Calamity.Types.Snowflake+import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) import Data.Aeson ((.:), (.:?)) import qualified Data.Aeson as Aeson+import Data.Colour (Colour) import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Read (decimal) import Data.Word+import Network.HTTP.Req ((/:), (/~)) import Optics.TH+import qualified TextShow import TextShow.TH +data UserBanner = UserBanner+  { userID :: Snowflake User+  , hash :: T.Text+  }+  deriving (Show, Eq)++instance CDNAsset UserBanner where+  assetURL UserBanner {hash, userID} =+    cdnURL /: "banners" /~ userID /: assetHashFile hash+ data User = User   { id :: Snowflake User   , username :: Text   , discriminator :: Text   , bot :: Maybe Bool-  , avatar :: Maybe Text+  , avatar :: Avatar   , mfaEnabled :: Maybe Bool+  , banner :: Maybe UserBanner+  , accentColour :: Maybe (Colour Double)+  , locale :: Maybe Text   , verified :: Maybe Bool   , email :: Maybe Text   , flags :: Maybe Word64   , premiumType :: Maybe Word64   }   deriving (Show, Eq)+  deriving (TextShow.TextShow) via TextShow.FromStringShow User   deriving (HasID User) via HasIDField "id" User   deriving (HasID Member) via HasIDFieldCoerce' "id" User  instance Aeson.FromJSON User where-  parseJSON = Aeson.withObject "User" $ \v ->+  parseJSON = Aeson.withObject "User" $ \v -> do+    uid <- v .: "id"+    avatarHash <- v .:? "avatar"+    discrim <- v .: "discriminator"+    discrim' <- case decimal discrim of+      Right (n, _) -> pure n+      Left e -> fail e+    let avatar = Avatar avatarHash uid discrim'+    banner <- (UserBanner uid <$>) <$> v .:? "banner"     User-      <$> v .: "id"+      <$> pure uid       <*> v .: "username"       <*> v .: "discriminator"       <*> v .:? "bot"-      <*> v .:? "avatar"+      <*> pure avatar       <*> v .:? "mfa_enabled"+      <*> pure banner+      <*> (fmap fromIntColour <$> v .:? "accent_color")+      <*> v .:? "locale"       <*> v .:? "verified"       <*> v .:? "email"       <*> v .:? "flags"@@ -83,7 +118,6 @@       Offline -> "offline"       Invisible -> "invisible" -$(deriveTextShow ''User) $(deriveTextShow 'PartialUser) $(deriveTextShow ''StatusType) $(makeFieldLabelsNoPrefix ''User)

@@ -0,0 +1,8 @@+-- | Users+module Calamity.Types.Model.User+    ( User ) where++data User++instance Show User+instance Eq User

@@ -19,6 +19,7 @@ import Data.Word import GHC.Records (HasField (getField)) import TextShow+import Web.HttpApiData (ToHttpApiData)  -- Thanks sbrg -- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78@@ -28,6 +29,7 @@   deriving (Eq, Ord, Data)   deriving newtype (Show, TextShow, FromJSONKey)   deriving newtype (ToJSONKey, U.Unboxable)+  deriving newtype (ToHttpApiData)  -- I'm pretty sure that Word64's hash just being 'fromIntegral' is a bad idea when -- attempting to use it in a hashmap, so swizzle the bits a bit to give a good

@@ -0,0 +1,22 @@+-- | CDN url stuff+module Calamity.Utils.CDNUrl (+  cdnURL,+  assetHashFile,+  isGIFAsset,+) where++import qualified Data.Text as T+import qualified Network.HTTP.Req as Req++-- | The CDN URL+cdnURL :: Req.Url 'Req.Https+cdnURL = Req.https "cdn.discordapp.com"++-- | Test if an asset hash is animated+isGIFAsset :: T.Text -> Bool+isGIFAsset = T.isPrefixOf "a_"++-- | Generate \'hash.ext\' for an asset hash. @ext@ will be \'gif\' for animated+-- assets, \'png\' otherwise.+assetHashFile :: T.Text -> T.Text+assetHashFile h = if isGIFAsset h then h <> ".gif" else h <> ".png"

@@ -1,5 +1,31 @@ # Changelog for Calamity +## 0.7.0.0+++ Added the `CDNAsset` typeclass for resolving CDN asset links and fetching+  them.++ Added the module `Calamity.Types.Model.Avatar` with the types `Avatar` and+  `MemberAvatar`++ Changed the `avatar` field of `User` and `Member` to be `Avatar` (the default+  avatar will be fetched if the user does not have one set).++ Added the field `banner` to `User` and `Member` with type `Maybe UserBanner`.++ Added the field `accentColour` to `User` and `Member` with type `Maybe (Colour Double)`.++ Added the field `locale` to `User` and `Member` with type `Maybe Text`.++ Added the field `Member.memberAvatar` with type `Text`. (discord limitation,+  the guild id is needed to construct the member's guild avatar url, but discord+  doesn't attach the guild id to the member...)++ Added the type `RoleIcon` to `Calamity.Types.Model.Guild.Role`.++ Added the field `Role.icon` with type `RoleIcon`.++ Added the field `Role.emoji` with type `RawEmoji`.++ Added the types `GuildIcon`, `GuildSplash`, `GuildDiscoverySplash`,+  `GuildBanner` to `Calamity.Types.Model.Guild.Guild`.++ Changed the type of `Guild.icon` to `Maybe GuildIcon`.++ Changed the type of `Guild.splash` to `Maybe GuildSplash`.++ Added the field `Guild.discoverySplash` with type `Maybe+  GuildDiscoverySplash`.++ Added the field `Guild.banner` with type `Maybe GuildBanner`.++ ## 0.6.0.0  + Updated the events `GuildMemberAddEvt`, `GuildMemberRemoveEvt`, and

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           calamity-version:        0.6.0.0+version:        0.7.0.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@@ -18,7 +18,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC == 8.10.7, GHC == 9.2.2+    GHC == 8.10.7, GHC == 9.2.4 extra-source-files:     README.md     ChangeLog.md@@ -84,6 +84,7 @@       Calamity.Types       Calamity.Types.LogEff       Calamity.Types.Model+      Calamity.Types.Model.Avatar       Calamity.Types.Model.Channel       Calamity.Types.Model.Channel.Attachment       Calamity.Types.Model.Channel.ChannelType@@ -118,6 +119,7 @@       Calamity.Types.Model.Voice       Calamity.Types.Model.Voice.VoiceRegion       Calamity.Types.Model.Voice.VoiceState+      Calamity.Types.CDNAsset       Calamity.Types.Partial       Calamity.Types.Snowflake       Calamity.Types.Tellable@@ -125,6 +127,7 @@       Calamity.Types.TokenEff       Calamity.Types.Upgradeable       Calamity.Utils+      Calamity.Utils.CDNUrl       Calamity.Utils.Colour       Calamity.Utils.Message       Calamity.Utils.Permissions