diff --git a/Calamity/Cache/InMemory.hs b/Calamity/Cache/InMemory.hs --- a/Calamity/Cache/InMemory.hs +++ b/Calamity/Cache/InMemory.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | A 'Cache' handler that operates in memory module Calamity.Cache.InMemory ( runCacheInMemory, @@ -13,33 +15,29 @@ import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake - -import Control.Lens +import Control.Applicative +import Data.Functor.Identity import Control.Monad.State.Strict - import Data.Foldable import qualified Data.HashMap.Strict as SH import qualified Data.HashSet as HS import Data.IORef - -import Control.DeepSeq -import GHC.Generics - +import Optics import qualified Polysemy as P import qualified Polysemy.AtomicState as P +import Optics.State.Operators ((?=), (%=)) data Cache f = Cache { user :: Maybe User - , guilds :: SM.SnowflakeMap Guild - , dms :: SM.SnowflakeMap DMChannel - , guildChannels :: SH.HashMap (Snowflake GuildChannel) Guild - , users :: SM.SnowflakeMap User - , unavailableGuilds :: HS.HashSet (Snowflake Guild) - , messages :: f (BS.BoundedStore Message) + , guilds :: !(SM.SnowflakeMap Guild) + , dms :: !(SM.SnowflakeMap DMChannel) + , guildChannels :: !(SH.HashMap (Snowflake GuildChannel) Guild) + , users :: !(SM.SnowflakeMap User) + , unavailableGuilds :: !(HS.HashSet (Snowflake Guild)) + , messages :: !(f (BS.BoundedStore Message)) } - deriving (Generic) -instance NFData (f (BS.BoundedStore Message)) => NFData (Cache f) +$(makeFieldLabelsNoPrefix ''Cache) type CacheWithMsg = Cache Identity type CacheNoMsg = Cache (Const ()) @@ -72,7 +70,7 @@ P.runAtomicStateIORef var $ P.reinterpret runCache' m runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a -runCache' act = P.atomicState' ((swap .) . force . runState $ runCache act) +runCache' act = P.atomicState' ((swap .) . runState $ runCache act) class MessageMod t where setMessage' :: Message -> State t () @@ -81,10 +79,10 @@ delMessage' :: Snowflake Message -> State t () instance MessageMod CacheWithMsg where - setMessage' m = #messages . _Wrapped %= BS.addItem m - getMessage' mid = use (#messages . _Wrapped . at mid) - getMessages' = toList <$> use (#messages . _Wrapped) - delMessage' mid = #messages . _Wrapped %= sans mid + setMessage' m = #messages % _1 %= BS.addItem m + getMessage' mid = use (#messages % _1 % at' mid) + getMessages' = toList <$> use (#messages % _1) + delMessage' mid = #messages % _1 %= sans mid instance MessageMod CacheNoMsg where setMessage' !_ = pure () @@ -98,23 +96,23 @@ runCache (SetGuild g) = do #guilds %= SM.insert g #guildChannels %= SH.filter (\v -> getID @Guild v /= getID @Guild g) - #guildChannels %= SH.union (SH.fromList $ map (,g) (SM.keys (g ^. #channels))) -runCache (GetGuild gid) = use (#guilds . at gid) -runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid)) + #guildChannels %= SH.union (SH.fromList $ map (, g) (SM.keys (g ^. #channels))) +runCache (GetGuild gid) = use (#guilds % at' gid) +runCache (GetGuildChannel cid) = use (#guildChannels % at' cid) <&> (>>= (^. #channels % at' cid)) runCache GetGuilds = SM.elems <$> use #guilds runCache (DelGuild gid) = do #guilds %= sans gid #guildChannels %= SH.filter (\v -> getID @Guild v /= gid) runCache (SetDM dm) = #dms %= SM.insert dm -runCache (GetDM did) = use (#dms . at did) +runCache (GetDM did) = use (#dms % at' did) runCache GetDMs = SM.elems <$> use #dms runCache (DelDM did) = #dms %= sans did runCache (SetUser u) = #users %= SM.insert u -runCache (GetUser uid) = use (#users . at uid) +runCache (GetUser uid) = use (#users % at' uid) runCache GetUsers = SM.elems <$> use #users runCache (DelUser uid) = #users %= sans uid runCache (SetUnavailableGuild gid) = #unavailableGuilds %= HS.insert gid -runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid) +runCache (IsUnavailableGuild gid) = use (#unavailableGuilds % contains gid) runCache GetUnavailableGuilds = HS.toList <$> use #unavailableGuilds runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid runCache (SetMessage m) = setMessage' m diff --git a/Calamity/Client/Client.hs b/Calamity/Client/Client.hs --- a/Calamity/Client/Client.hs +++ b/Calamity/Client/Client.hs @@ -23,7 +23,6 @@ import Calamity.Gateway.Intents import Calamity.Gateway.Types import Calamity.HTTP.Internal.Ratelimit -import Calamity.Types.TokenEff import Calamity.Internal.ConstructorName import Calamity.Internal.RunIntoIO import qualified Calamity.Internal.SnowflakeMap as SM @@ -39,16 +38,15 @@ import qualified Calamity.Types.Model.Voice as V import Calamity.Types.Snowflake import Calamity.Types.Token +import Calamity.Types.TokenEff import Control.Concurrent.Chan.Unagi import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception (SomeException) -import Control.Lens hiding ((<.>)) import Control.Monad import Data.Default.Class import Data.Dynamic import Data.Foldable -import Data.Generics.Product.Subtype import Data.IORef import Data.Maybe import Data.Proxy @@ -57,6 +55,7 @@ import qualified Df1 import qualified Di.Core as DC import qualified DiPolysemy as Di +import Optics import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P @@ -446,7 +445,7 @@ handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do updateCache evt Just guild <- getGuild (getID chan) - Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan) + Just newChan <- pure $ GuildChannel' <$> guild ^. #channels % at (getID chan) pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do Just oldChan <- DMChannel' <<$>> getDM (getID chan) @@ -455,14 +454,14 @@ pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do Just oldGuild <- getGuild (getID chan) - Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan) + Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels % at (getID chan) updateCache evt Just newGuild <- getGuild (getID chan) - Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan) + Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels % at (getID chan) pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do Just oldGuild <- getGuild (getID chan) - Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan) + Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels % at (getID chan) updateCache evt pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do @@ -471,8 +470,8 @@ pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) -- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do --- chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just) --- <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just) +-- chan <- (GuildChannel' <$> os ^? #channels % at (coerceSnowflake channelID) . _Just) +-- <|> (DMChannel' <$> os ^? #dms % at (coerceSnowflake channelID) . _Just) -- pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh) handleEvent' eh evt@(GuildCreate guild) = do @@ -518,41 +517,41 @@ handleEvent' eh evt@(GuildMemberAdd gid member) = do updateCache evt Just guild <- getGuild gid - Just member <- pure $ guild ^. #members . at (getID member) + Just member <- pure $ guild ^. #members % at (getID member) pure $ map ($ member) (getEventHandlers @'GuildMemberAddEvt eh) handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData {user, guildID}) = do Just guild <- getGuild guildID - Just member <- pure $ guild ^. #members . at (getID user) + Just member <- pure $ guild ^. #members % at (getID user) updateCache evt pure $ map ($ member) (getEventHandlers @'GuildMemberRemoveEvt eh) handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData {user, guildID}) = do Just oldGuild <- getGuild guildID - Just oldMember <- pure $ oldGuild ^. #members . at (getID user) + Just oldMember <- pure $ oldGuild ^. #members % at (getID user) updateCache evt Just newGuild <- getGuild guildID - Just newMember <- pure $ newGuild ^. #members . at (getID user) + Just newMember <- pure $ newGuild ^. #members % at (getID user) pure $ map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData {members, guildID}) = do updateCache evt Just guild <- getGuild guildID let memberIDs = map (getID @Member) members - let members' = mapMaybe (\mid -> guild ^. #members . at mid) memberIDs + let members' = mapMaybe (\mid -> guild ^. #members % at mid) memberIDs pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh) handleEvent' eh evt@(GuildRoleCreate GuildRoleData {guildID, role}) = do updateCache evt Just guild <- getGuild guildID - Just role' <- pure $ guild ^. #roles . at (getID role) + Just role' <- pure $ guild ^. #roles % at (getID role) pure $ map ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh) handleEvent' eh evt@(GuildRoleUpdate GuildRoleData {guildID, role}) = do Just oldGuild <- getGuild guildID - Just oldRole <- pure $ oldGuild ^. #roles . at (getID role) + Just oldRole <- pure $ oldGuild ^. #roles % at (getID role) updateCache evt Just newGuild <- getGuild guildID - Just newRole <- pure $ newGuild ^. #roles . at (getID role) + Just newRole <- pure $ newGuild ^. #roles % at (getID role) pure $ map ($ (newGuild, oldRole, newRole)) (getEventHandlers @'GuildRoleUpdateEvt eh) handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData {guildID, roleID}) = do Just guild <- getGuild guildID - Just role <- pure $ guild ^. #roles . at roleID + Just role <- pure $ guild ^. #roles % at roleID updateCache evt pure $ map ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh) handleEvent' eh (InviteCreate d) = do @@ -632,12 +631,12 @@ pure $ rawActions <> actions handleEvent' eh evt@(PresenceUpdate PresenceUpdateData {userID, presence = Presence {guildID}}) = do Just oldGuild <- getGuild guildID - Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID) + Just oldMember <- pure $ oldGuild ^. #members % at (coerceSnowflake userID) updateCache evt Just newGuild <- getGuild guildID - Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID) - let oldUser :: User = upcast oldMember - newUser :: User = upcast newMember + Just newMember <- pure $ newGuild ^. #members % at (coerceSnowflake userID) + let oldUser :: User = let Member {..} = oldMember in User {..} + newUser :: User = let Member {..} = newMember in User {..} userUpdates = if oldUser /= newUser then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh) @@ -647,7 +646,7 @@ case guildID of Just gid -> do Just guild <- getGuild gid - Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID) + Just chan <- pure $ GuildChannel' <$> guild ^. #channels % at (coerceSnowflake channelID) pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh) Nothing -> do Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID) @@ -678,7 +677,7 @@ updateCache (ChannelUpdate (DMChannel' chan)) = updateDM (getID chan) (update chan) updateCache (ChannelUpdate (GuildChannel' chan)) = - updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan) + updateGuild (getID chan) (#channels % ix (getID chan) %~ update chan) updateCache (ChannelDelete (DMChannel' chan)) = delDM (getID chan) updateCache (ChannelDelete (GuildChannel' chan)) = @@ -687,7 +686,7 @@ isNew <- isUnavailableGuild (getID guild) when isNew $ delUnavailableGuild (getID guild) setGuild guild - for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser + for_ (SM.elems (guild ^. #members)) (\Member {..} -> setUser User {..}) updateCache (GuildUpdate guild) = updateGuild (getID guild) (update guild) updateCache (GuildDelete UnavailableGuild {id, unavailable}) = @@ -697,13 +696,13 @@ updateCache (GuildEmojisUpdate GuildEmojisUpdateData {guildID, emojis}) = updateGuild guildID (#emojis .~ SM.fromList emojis) updateCache (GuildMemberAdd gid member) = do - setUser (member ^. super) - updateGuild gid (#members . at (getID member) ?~ member) + setUser $ (\Member {..} -> User {..}) member + updateGuild gid (#members % at (getID member) ?~ member) updateCache (GuildMemberRemove GuildMemberRemoveData {guildID, user}) = updateGuild guildID (#members %~ sans (getID user)) updateCache (GuildMemberUpdate GuildMemberUpdateData {guildID, roles = AesonVector roles, user, nick}) = do setUser user - updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) + updateGuild guildID (#members % ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) updateCache (GuildMembersChunk GuildMembersChunkData {guildID, members}) = traverse_ (updateCache . GuildMemberAdd guildID) members updateCache (GuildRoleCreate GuildRoleData {guildID, role}) = @@ -727,10 +726,9 @@ (getID reaction) ( \m -> case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of - [] -> m & #reactions <>~ [Reaction 1 isMe (reaction ^. #emoji)] + [] -> m & #reactions %~ (<> [Reaction 1 isMe (reaction ^. #emoji)]) _ -> - m & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji)) - %~ (#count +~ 1) . (#me ||~ isMe) + m & #reactions % traversed %~ updateReactionAdd isMe (reaction ^. #emoji) ) updateCache (MessageReactionRemove reaction) = do isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser @@ -738,14 +736,13 @@ (getID reaction) ( \m -> m - & #reactions . traverse . filtered ((== (reaction ^. #emoji)) . (^. #emoji)) - %~ (#count -~ 1) . (#me &&~ not isMe) + & #reactions % traversed %~ updateReactionRemove isMe (reaction ^. #emoji) & #reactions %~ filter (\r -> r ^. #count /= 0) ) updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) = updateMessage messageID (#reactions .~ mempty) updateCache (PresenceUpdate PresenceUpdateData {userID, presence}) = - updateGuild (getID presence) (#presences . at userID ?~ presence) + updateGuild (getID presence) (#presences % at userID ?~ presence) updateCache (UserUpdate user) = setBotUser user -- we don't handle group channels currently updateCache (ChannelCreate (GroupChannel' _)) = pure () @@ -774,3 +771,19 @@ -- we don't update the cache from interactions -- TODO: should we? updateCache (InteractionCreate _) = pure () + +updateReactionAdd :: Bool -> RawEmoji -> Reaction -> Reaction +updateReactionAdd isMe emoji reaction = + if emoji == reaction ^. #emoji + then + reaction & #count %~ succ + & #me %~ (|| isMe) + else reaction + +updateReactionRemove :: Bool -> RawEmoji -> Reaction -> Reaction +updateReactionRemove isMe emoji reaction = + if emoji == reaction ^. #emoji + then + reaction & #count %~ pred + & #me %~ (&& not isMe) + else reaction diff --git a/Calamity/Client/ShardManager.hs b/Calamity/Client/ShardManager.hs --- a/Calamity/Client/ShardManager.hs +++ b/Calamity/Client/ShardManager.hs @@ -7,9 +7,9 @@ import Calamity.Internal.Utils import Control.Concurrent.MVar import Control.Concurrent.STM -import Control.Lens import Control.Monad import Data.Traversable +import Optics import Polysemy (Sem) import qualified Polysemy as P import qualified Polysemy.Fail as P diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs --- a/Calamity/Client/Types.hs +++ b/Calamity/Client/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Types for the client module Calamity.Client.Types ( Client (..), @@ -49,13 +51,11 @@ import qualified Df1 import qualified Di.Core as DC import GHC.Exts (fromList) -import GHC.Generics +import Optics.TH import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P import qualified Polysemy.Reader as P -import TextShow -import qualified TextShow.Generic as TSG data Client = Client { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))] @@ -67,7 +67,6 @@ , ehidCounter :: IORef Integer , initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message) } - deriving (Generic) -- | Constraints required by the bot client type BotC r = @@ -177,16 +176,14 @@ GuildCreateNew | -- | The guild is becoming available GuildCreateAvailable - deriving (Generic, Show) - deriving (TextShow) via TSG.FromGeneric GuildCreateStatus + deriving (Show) data GuildDeleteStatus = -- | The guild became unavailable GuildDeleteUnavailable | -- | The bot was removed from the guild GuildDeleteRemoved - deriving (Generic, Show) - deriving (TextShow) via TSG.FromGeneric GuildDeleteStatus + deriving (Show) {- | A type family to decide what the parameters for an event handler should be determined by the type of event it is handling. @@ -384,3 +381,5 @@ unwrapEventHandler @( 'CustomEvt Void) $ fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler ( 'CustomEvt Void))) in maybe mempty (map eh . unwrapCustomEHTypeStorage) $ TM.lookup @a handlerMap + +$(makeFieldLabelsNoPrefix ''Client) diff --git a/Calamity/Commands/CalamityParsers.hs b/Calamity/Commands/CalamityParsers.hs --- a/Calamity/Commands/CalamityParsers.hs +++ b/Calamity/Commands/CalamityParsers.hs @@ -12,7 +12,7 @@ import Calamity.Types.Snowflake import CalamityCommands.ParameterInfo import CalamityCommands.Parser -import Control.Lens hiding (Context) +import Optics import Control.Monad import Control.Monad.Trans (lift) import Data.Maybe (fromMaybe, isJust) @@ -80,7 +80,7 @@ ( \mid -> do ctx <- P.ask guild <- join <$> getGuild `traverse` ctxGuildID ctx - pure $ guild ^? _Just . #members . ix mid + pure $ guild ^? _Just % #members % ix mid ) parameterDescription = "user mention or id" @@ -110,7 +110,7 @@ ( \cid -> do ctx <- P.ask guild <- join <$> getGuild `traverse` ctxGuildID ctx - pure $ guild ^? _Just . #channels . ix cid + pure $ guild ^? _Just % #channels % ix cid ) parameterDescription = "channel mention or id" @@ -140,7 +140,7 @@ ( \eid -> do ctx <- P.ask guild <- join <$> getGuild `traverse` ctxGuildID ctx - pure $ guild ^? _Just . #emojis . ix eid + pure $ guild ^? _Just % #emojis % ix eid ) parameterDescription = "emoji or id" @@ -164,7 +164,7 @@ ( \rid -> do ctx <- P.ask guild <- join <$> getGuild `traverse` ctxGuildID ctx - pure $ guild ^? _Just . #roles . ix rid + pure $ guild ^? _Just % #roles % ix rid ) parameterDescription = "role mention or id" diff --git a/Calamity/Commands/Context.hs b/Calamity/Commands/Context.hs --- a/Calamity/Commands/Context.hs +++ b/Calamity/Commands/Context.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Command invokation context module Calamity.Commands.Context ( CalamityCommandContext (..), @@ -17,14 +19,12 @@ import Calamity.Types.Tellable import qualified CalamityCommands.Context as CC import Control.Applicative -import Control.Lens hiding (Context) import Control.Monad import qualified Data.Text as T -import GHC.Generics +import Optics import qualified Polysemy as P import qualified Polysemy.Fail as P -import TextShow -import qualified TextShow.Generic as TSG +import qualified TextShow class CommandContext c => CalamityCommandContext c where -- | The id of the channel that invoked this command @@ -61,12 +61,14 @@ , -- | The message remaining after consuming the prefix unparsedParams :: T.Text } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric FullContext + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow FullContext deriving (HasID Channel) via HasIDField "channel" FullContext deriving (HasID Message) via HasIDField "message" FullContext deriving (HasID User) via HasIDField "user" FullContext +$(makeFieldLabelsNoPrefix ''FullContext) + instance CC.CommandContext IO FullContext () where ctxPrefix = (^. #prefix) ctxCommand = (^. #command) @@ -91,8 +93,8 @@ buildContext :: P.Member CacheEff r => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext) buildContext msg usr mem prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do guild <- join <$> getGuild `traverse` (msg ^. #guildID) - let member = mem <|> guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg) - let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg) + let member = mem <|> guild ^? _Just % #members % ix (coerceSnowflake $ getID @User msg) + let gchan = guild ^? _Just % #channels % ix (coerceSnowflake $ getID @Channel msg) Just channel <- case gchan of Just chan -> pure . pure $ GuildChannel' chan Nothing -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg) @@ -120,12 +122,14 @@ , -- | The message remaining after consuming the prefix unparsedParams :: T.Text } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric LightContext + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow LightContext deriving (HasID Channel) via HasIDField "channelID" LightContext deriving (HasID Message) via HasIDField "message" LightContext deriving (HasID User) via HasIDField "user" LightContext +$(makeFieldLabelsNoPrefix ''LightContext) + instance CC.CommandContext IO LightContext () where ctxPrefix = (^. #prefix) ctxCommand = (^. #command) @@ -134,7 +138,7 @@ instance CalamityCommandContext LightContext where ctxChannelID = (^. #channelID) ctxGuildID = (^. #guildID) - ctxUserID = (^. #user . #id) + ctxUserID = (^. #user % #id) ctxMessage = (^. #message) instance Tellable LightContext where diff --git a/Calamity/Commands/Dsl.hs b/Calamity/Commands/Dsl.hs --- a/Calamity/Commands/Dsl.hs +++ b/Calamity/Commands/Dsl.hs @@ -144,7 +144,7 @@ @ 'Calamity.Commands.Dsl.command' \@\'['CalamityCommands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), 'CalamityCommands.Parser.Named' "reason" ('CalamityCommands.Parser.KleeneStarConcat' 'T.Text')] - "ban" $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of + "ban" $ \\ctx uid r -> case (ctx 'Optics.^.' #guild) of 'Just' guild -> do 'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r) 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) @@ -178,7 +178,7 @@ @ 'commandA' \@\'['CalamityCommands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), 'CalamityCommands.Parser.Named' "reason" ('CalamityCommands.Parser.KleeneStarConcat' 'T.Text')] - "ban" [] $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of + "ban" [] $ \\ctx uid r -> case (ctx 'Optics.^.' #guild) of 'Just' guild -> do 'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r) 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) diff --git a/Calamity/Commands/Utils.hs b/Calamity/Commands/Utils.hs --- a/Calamity/Commands/Utils.hs +++ b/Calamity/Commands/Utils.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} -- | Command handler utilities module Calamity.Commands.Utils ( @@ -27,8 +26,8 @@ import Control.Monad import qualified Data.Text as T import Data.Typeable -import GHC.Generics (Generic) import qualified Polysemy as P +import Optics.TH (makeFieldLabelsNoPrefix) data CmdInvokeFailReason c = NoContext @@ -39,7 +38,7 @@ { ctx :: c , err :: CC.CommandError } - deriving (Show, Generic) + deriving (Show) data CommandNotFound = CommandNotFound { msg :: Message @@ -48,12 +47,12 @@ , -- | The groups that were successfully parsed path :: [T.Text] } - deriving (Show, Generic) + deriving (Show) newtype CommandInvoked c = CommandInvoked { ctx :: c } - deriving stock (Show, Generic) + deriving stock (Show) -- | A default interpretation for 'CC.ParsePrefix' that uses a single constant prefix. useConstantPrefix :: T.Text -> P.Sem (CC.ParsePrefix Message ': r) a -> P.Sem r a @@ -114,3 +113,8 @@ Nothing -> pure () _ -> pure () pure (remove, handler, res) + +$(makeFieldLabelsNoPrefix ''CmdInvokeFailReason) +$(makeFieldLabelsNoPrefix ''CtxCommandError) +$(makeFieldLabelsNoPrefix ''CommandNotFound) +$(makeFieldLabelsNoPrefix ''CommandInvoked) diff --git a/Calamity/Gateway/DispatchEvents.hs b/Calamity/Gateway/DispatchEvents.hs --- a/Calamity/Gateway/DispatchEvents.hs +++ b/Calamity/Gateway/DispatchEvents.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | module containing all dispatch events module Calamity.Gateway.DispatchEvents where -import Calamity.Internal.AesonThings import Calamity.Internal.ConstructorName import Calamity.Internal.UnixTimestamp import Calamity.Internal.Utils @@ -18,227 +19,326 @@ import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Kind (Type) import Data.Text (Text) import Data.Time import Data.Typeable (Typeable) import GHC.Generics +import Optics.TH data CalamityEvent - = Dispatch - Int - -- ^ The shard that pushed this event - DispatchData - -- ^ The attached data - | -- | The data sent to the custom event - forall (a :: Type). Typeable a => Custom a - | ShutDown + = Dispatch + Int + -- ^ The shard that pushed this event + DispatchData + -- ^ The attached data + | -- | The data sent to the custom event + forall (a :: Type). Typeable a => Custom a + | ShutDown data DispatchData - = Ready !ReadyData - | Resumed - | ChannelCreate !Channel - | ChannelUpdate !Channel - | ChannelDelete !Channel - | ChannelPinsUpdate !ChannelPinsUpdateData - | GuildCreate !Guild - | GuildUpdate !UpdatedGuild - | GuildDelete !UnavailableGuild - | GuildBanAdd !BanData - | GuildBanRemove !BanData - | GuildEmojisUpdate !GuildEmojisUpdateData - | GuildIntegrationsUpdate !GuildIntegrationsUpdateData - | GuildMemberAdd !(Snowflake Guild) !Member - | GuildMemberRemove !GuildMemberRemoveData - | GuildMemberUpdate !GuildMemberUpdateData - | GuildMembersChunk !GuildMembersChunkData - | GuildRoleCreate !GuildRoleData - | GuildRoleUpdate !GuildRoleData - | GuildRoleDelete !GuildRoleDeleteData - | InviteCreate !InviteCreateData - | InviteDelete !InviteDeleteData - | MessageCreate !Message !(Maybe User) !(Maybe Member) - | MessageUpdate !UpdatedMessage !(Maybe User) !(Maybe Member) - | MessageDelete !MessageDeleteData - | MessageDeleteBulk !MessageDeleteBulkData - | MessageReactionAdd !ReactionEvtData - | MessageReactionRemove !ReactionEvtData - | MessageReactionRemoveAll !MessageReactionRemoveAllData - | PresenceUpdate !PresenceUpdateData - | TypingStart !TypingStartData - | UserUpdate !User - | VoiceStateUpdate !VoiceState - | VoiceServerUpdate !VoiceServerUpdateData - | WebhooksUpdate !WebhooksUpdateData - | InteractionCreate !Interaction - deriving (Show, Generic, CtorName) + = Ready !ReadyData + | Resumed + | ChannelCreate !Channel + | ChannelUpdate !Channel + | ChannelDelete !Channel + | ChannelPinsUpdate !ChannelPinsUpdateData + | GuildCreate !Guild + | GuildUpdate !UpdatedGuild + | GuildDelete !UnavailableGuild + | GuildBanAdd !BanData + | GuildBanRemove !BanData + | GuildEmojisUpdate !GuildEmojisUpdateData + | GuildIntegrationsUpdate !GuildIntegrationsUpdateData + | GuildMemberAdd !(Snowflake Guild) !Member + | GuildMemberRemove !GuildMemberRemoveData + | GuildMemberUpdate !GuildMemberUpdateData + | GuildMembersChunk !GuildMembersChunkData + | GuildRoleCreate !GuildRoleData + | GuildRoleUpdate !GuildRoleData + | GuildRoleDelete !GuildRoleDeleteData + | InviteCreate !InviteCreateData + | InviteDelete !InviteDeleteData + | MessageCreate !Message !(Maybe User) !(Maybe Member) + | MessageUpdate !UpdatedMessage !(Maybe User) !(Maybe Member) + | MessageDelete !MessageDeleteData + | MessageDeleteBulk !MessageDeleteBulkData + | MessageReactionAdd !ReactionEvtData + | MessageReactionRemove !ReactionEvtData + | MessageReactionRemoveAll !MessageReactionRemoveAllData + | PresenceUpdate !PresenceUpdateData + | TypingStart !TypingStartData + | UserUpdate !User + | VoiceStateUpdate !VoiceState + | VoiceServerUpdate !VoiceServerUpdateData + | WebhooksUpdate !WebhooksUpdateData + | InteractionCreate !Interaction + deriving (Show, Generic, CtorName) data ReadyData = ReadyData - { v :: Integer - , user :: User - , guilds :: [UnavailableGuild] - , sessionID :: Text - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON ReadyData + { v :: Integer + , user :: User + , guilds :: [UnavailableGuild] + , sessionID :: Text + } + deriving (Show) +instance Aeson.FromJSON ReadyData where + parseJSON = Aeson.withObject "ReadyData" $ \v -> + ReadyData + <$> v .: "v" + <*> v .: "user" + <*> v .: "guilds" + <*> v .: "session_id" + data ChannelPinsUpdateData = ChannelPinsUpdateData - { channelID :: Snowflake Channel - , lastPinTimestamp :: Maybe UTCTime - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON ChannelPinsUpdateData + { channelID :: Snowflake Channel + , lastPinTimestamp :: Maybe UTCTime + } + deriving (Show) +instance Aeson.FromJSON ChannelPinsUpdateData where + parseJSON = Aeson.withObject "ChannelPinsUpdateData" $ \v -> + ChannelPinsUpdateData + <$> v .: "channel_id" + <*> v .: "last_pin_timestamp" + data GuildEmojisUpdateData = GuildEmojisUpdateData - { guildID :: Snowflake Guild - , emojis :: [Emoji] - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON GuildEmojisUpdateData + { guildID :: Snowflake Guild + , emojis :: [Emoji] + } + deriving (Show) +instance Aeson.FromJSON GuildEmojisUpdateData where + parseJSON = Aeson.withObject "GuildEmojisUpdateData" $ \v -> + GuildEmojisUpdateData + <$> v .: "guild_id" + <*> v .: "emojis" + newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData - { guildID :: Snowflake Guild - } - deriving newtype (Show, Generic) - deriving (FromJSON) via CalamityJSON GuildIntegrationsUpdateData + { guildID :: Snowflake Guild + } + deriving stock (Show) +instance Aeson.FromJSON GuildIntegrationsUpdateData where + parseJSON = Aeson.withObject "GuildIntegrationsUpdateData" $ \v -> + GuildIntegrationsUpdateData + <$> v .: "guild_id" + data GuildMemberRemoveData = GuildMemberRemoveData - { guildID :: Snowflake Guild - , user :: User - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON GuildMemberRemoveData + { guildID :: Snowflake Guild + , user :: User + } + deriving (Show) +instance Aeson.FromJSON GuildMemberRemoveData where + parseJSON = Aeson.withObject "GuildMemberRemoveData" $ \v -> + GuildMemberRemoveData + <$> v .: "guild_id" + <*> v .: "user" + data GuildMemberUpdateData = GuildMemberUpdateData - { guildID :: Snowflake Guild - , roles :: AesonVector (Snowflake Role) - , user :: User - , nick :: Maybe Text - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON GuildMemberUpdateData + { guildID :: Snowflake Guild + , roles :: AesonVector (Snowflake Role) + , user :: User + , nick :: Maybe Text + } + deriving (Show) +instance Aeson.FromJSON GuildMemberUpdateData where + parseJSON = Aeson.withObject "GuildMemberUpdateData" $ \v -> + GuildMemberUpdateData + <$> v .: "guild_id" + <*> v .: "roles" + <*> v .: "user" + <*> v .:? "nick" + data GuildMembersChunkData = GuildMembersChunkData - { guildID :: Snowflake Guild - , members :: [Member] - } - deriving (Show, Generic) + { guildID :: Snowflake Guild + , members :: [Member] + } + deriving (Show) -instance FromJSON GuildMembersChunkData where - parseJSON = withObject "GuildMembersChunkData" $ \v -> do - guildID <- v .: "guild_id" +instance Aeson.FromJSON GuildMembersChunkData where + parseJSON = Aeson.withObject "GuildMembersChunkData" $ \v -> do + guildID <- v Aeson..: "guild_id" - members' <- do - members' <- v .: "members" - traverse (parseJSON . Object) members' + members' <- do + members' <- v Aeson..: "members" + traverse (Aeson.parseJSON . Aeson.Object) members' - pure $ GuildMembersChunkData guildID members' + pure $ GuildMembersChunkData guildID members' data GuildRoleData = GuildRoleData - { guildID :: Snowflake Guild - , role :: Role - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON GuildRoleData + { guildID :: Snowflake Guild + , role :: Role + } + deriving (Show) +instance Aeson.FromJSON GuildRoleData where + parseJSON = Aeson.withObject "GuildRoleData" $ \v -> + GuildRoleData + <$> v .: "guild_id" + <*> v .: "role" + data GuildRoleDeleteData = GuildRoleDeleteData - { guildID :: Snowflake Guild - , roleID :: Snowflake Role - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON GuildRoleDeleteData + { guildID :: Snowflake Guild + , roleID :: Snowflake Role + } + deriving (Show) +instance Aeson.FromJSON GuildRoleDeleteData where + parseJSON = Aeson.withObject "GuildRoleDeleteData" $ \v -> + GuildRoleDeleteData + <$> v .: "guild_id" + <*> v .: "role_id" data InviteCreateData = InviteCreateData - { channelID :: Snowflake Channel - , code :: Text - , createdAt :: UTCTime - , guildID :: Maybe (Snowflake Guild) - , inviter :: Maybe (Snowflake User) - , maxAge :: Int - , maxUses :: Int - , targetUser :: Maybe (Snowflake User) - , targetUserType :: Maybe Integer - , temporary :: Bool - , uses :: Integer - } - deriving (Show, Generic) - deriving - (FromJSON) - via WithSpecialCases - '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"] - InviteCreateData + { channelID :: Snowflake Channel + , code :: Text + , createdAt :: UTCTime + , guildID :: Maybe (Snowflake Guild) + , inviter :: Maybe (Snowflake User) + , maxAge :: Int + , maxUses :: Int + , targetUser :: Maybe (Snowflake User) + , targetUserType :: Maybe Integer + , temporary :: Bool + , uses :: Integer + } + deriving (Show) +instance Aeson.FromJSON InviteCreateData where + parseJSON = Aeson.withObject "InviteCreateData" $ \v -> do + let inviter = (v .:? "inviter") >>= traverse (.: "id") + targetUser = (v .:? "target_user") >>= traverse (.: "id") + + InviteCreateData + <$> v .: "channel_id" + <*> v .: "code" + <*> v .: "created_at" + <*> v .:? "guild_id" + <*> inviter + <*> v .: "max_age" + <*> v .: "max_uses" + <*> targetUser + <*> v .:? "target_user_type" + <*> v .: "temporary" + <*> v .: "uses" + data InviteDeleteData = InviteDeleteData - { channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , code :: Text - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON InviteDeleteData + { channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , code :: Text + } + deriving (Show) +instance Aeson.FromJSON InviteDeleteData where + parseJSON = Aeson.withObject "InviteDeleteData" $ \v -> + InviteDeleteData + <$> v .: "channel_id" + <*> v .:? "guild_id" + <*> v .: "code" + data MessageDeleteData = MessageDeleteData - { id :: Snowflake Message - , channelID :: Snowflake Channel - , guildID :: Snowflake Guild - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON MessageDeleteData + { id :: Snowflake Message + , channelID :: Snowflake Channel + , guildID :: Snowflake Guild + } + deriving (Show) +instance Aeson.FromJSON MessageDeleteData where + parseJSON = Aeson.withObject "MessageDeleteData" $ \v -> + MessageDeleteData + <$> v .: "id" + <*> v .: "channel_id" + <*> v .: "guild_id" + data MessageDeleteBulkData = MessageDeleteBulkData - { guildID :: Snowflake Guild - , channelID :: Snowflake Channel - , ids :: [Snowflake Message] - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON MessageDeleteBulkData + { guildID :: Snowflake Guild + , channelID :: Snowflake Channel + , ids :: [Snowflake Message] + } + deriving (Show) +instance Aeson.FromJSON MessageDeleteBulkData where + parseJSON = Aeson.withObject "MessageDeleteBulkData" $ \v -> + MessageDeleteBulkData + <$> v .: "guild_id" + <*> v .: "channel_id" + <*> v .: "ids" + data MessageReactionRemoveAllData = MessageReactionRemoveAllData - { channelID :: Snowflake Channel - , messageID :: Snowflake Message - , guildID :: Maybe (Snowflake Guild) - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON MessageReactionRemoveAllData + { channelID :: Snowflake Channel + , messageID :: Snowflake Message + , guildID :: Maybe (Snowflake Guild) + } + deriving (Show) +instance Aeson.FromJSON MessageReactionRemoveAllData where + parseJSON = Aeson.withObject "MessageReactionRemoveAllData" $ \v -> + MessageReactionRemoveAllData + <$> v .: "channel_id" + <*> v .: "message_id" + <*> v .: "guild_id" + data PresenceUpdateData = PresenceUpdateData - { userID :: Snowflake User - , presence :: Presence - } - deriving (Show, Generic) + { userID :: Snowflake User + , presence :: Presence + } + deriving (Show) -instance FromJSON PresenceUpdateData where - parseJSON = withObject "PresenceUpdate" $ \v -> do - user <- (v .: "user") >>= (.: "id") - presence <- parseJSON $ Object v - pure $ PresenceUpdateData user presence +instance Aeson.FromJSON PresenceUpdateData where + parseJSON = Aeson.withObject "PresenceUpdate" $ \v -> do + user <- (v Aeson..: "user") >>= (Aeson..: "id") + presence <- Aeson.parseJSON $ Aeson.Object v + pure $ PresenceUpdateData user presence data TypingStartData = TypingStartData - { channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , userID :: Snowflake User - , timestamp :: UnixTimestamp - } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON TypingStartData + { channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , userID :: Snowflake User + , timestamp :: UnixTimestamp + } + deriving (Show) -newtype VoiceServerUpdateData = VoiceServerUpdateData Value - deriving newtype (Show, Generic) - deriving newtype (ToJSON, FromJSON) +instance Aeson.FromJSON TypingStartData where + parseJSON = Aeson.withObject "TypingStartData" $ \v -> + TypingStartData + <$> v .: "channel_id" + <*> v .: "guild_id" + <*> v .: "user_id" + <*> v .: "timestamp" -newtype WebhooksUpdateData = WebhooksUpdateData Value - deriving newtype (Show, Generic) - deriving newtype (ToJSON, FromJSON) +newtype VoiceServerUpdateData = VoiceServerUpdateData Aeson.Value + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Aeson.FromJSON) +newtype WebhooksUpdateData = WebhooksUpdateData Aeson.Value + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Aeson.FromJSON) + data ReactionEvtData = ReactionEvtData - { userID :: Snowflake User - , channelID :: Snowflake Channel - , messageID :: Snowflake Message - , guildID :: Maybe (Snowflake Guild) - , emoji :: RawEmoji - } - deriving (Eq, Show, Generic) - deriving (ToJSON, FromJSON) via CalamityJSON ReactionEvtData - deriving (HasID User) via HasIDField "userID" ReactionEvtData - deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData - deriving (HasID Message) via HasIDField "messageID" ReactionEvtData + { userID :: Snowflake User + , channelID :: Snowflake Channel + , messageID :: Snowflake Message + , guildID :: Maybe (Snowflake Guild) + , emoji :: RawEmoji + } + deriving (Eq, Show) + deriving (HasID User) via HasIDField "userID" ReactionEvtData + deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData + deriving (HasID Message) via HasIDField "messageID" ReactionEvtData + +instance Aeson.FromJSON ReactionEvtData where + parseJSON = Aeson.withObject "ReactionEvtData" $ \v -> + ReactionEvtData + <$> v .: "user_id" + <*> v .: "channel_id" + <*> v .: "message_id" + <*> v .: "guild_id" + <*> v .: "emoji" + +$(makeFieldLabelsNoPrefix ''ReadyData) +$(makeFieldLabelsNoPrefix ''ReactionEvtData) diff --git a/Calamity/Gateway/Shard.hs b/Calamity/Gateway/Shard.hs --- a/Calamity/Gateway/Shard.hs +++ b/Calamity/Gateway/Shard.hs @@ -7,32 +7,88 @@ newShard, ) where -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Intents -import Calamity.Gateway.Types -import Calamity.Internal.RunIntoIO -import Calamity.Internal.Utils -import Calamity.Metrics.Eff -import Calamity.Types.LogEff -import Calamity.Types.Token -import Control.Concurrent -import Control.Concurrent.Async +import Calamity.Gateway.DispatchEvents ( + CalamityEvent (Dispatch), + DispatchData (Ready), + ) +import Calamity.Gateway.Intents (Intents) +import Calamity.Gateway.Types ( + ControlMessage (..), + IdentifyData ( + IdentifyData, + compress, + intents, + largeThreshold, + presence, + properties, + shard, + token + ), + IdentifyProps (IdentifyProps, browser, device), + ReceivedDiscordMessage ( + EvtDispatch, + HeartBeatAck, + HeartBeatReq, + Hello, + InvalidSession, + Reconnect + ), + ResumeData (ResumeData, seq, sessionID, token), + SentDiscordMessage (HeartBeat, Identify, Resume, StatusUpdate), + Shard (..), + ShardC, + ShardFlowControl (..), + ShardMsg (..), + ShardState (ShardState, wsConn), + StatusUpdateData, + ) +import Calamity.Internal.RunIntoIO (bindSemToIO) +import Calamity.Internal.Utils ( + debug, + error, + info, + leftToMaybe, + swap, + unlessM, + untilJustFinalIO, + whenJust, + whileMFinalIO, + ) +import Calamity.Metrics.Eff ( + MetricEff, + modifyGauge, + registerGauge, + ) +import Calamity.Types.LogEff (LogEff) +import Calamity.Types.Token (Token, rawToken) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, cancel) import qualified Control.Concurrent.Chan.Unagi as UC -import Control.Concurrent.STM -import Control.Concurrent.STM.TBMQueue -import Control.Exception +import Control.Concurrent.STM (STM, atomically, retry) +import Control.Concurrent.STM.TBMQueue ( + TBMQueue, + closeTBMQueue, + newTBMQueueIO, + readTBMQueue, + tryWriteTBMQueue, + writeTBMQueue, + ) +import Control.Exception ( + Exception (fromException), + SomeException, + ) import qualified Control.Exception.Safe as Ex -import Control.Lens -import Control.Monad -import Control.Monad.State.Lazy +import Optics +import Optics.State.Operators +import Control.Monad (void, when) +import Control.Monad.State.Lazy (runState) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS import Data.Default.Class (def) -import Data.Functor -import Data.IORef -import Data.Maybe +import Data.IORef (newIORef) +import Data.Maybe (fromMaybe) import qualified Data.Text as T -import DiPolysemy hiding (debug, error, info) +import DiPolysemy (attr, push) import qualified Network.Connection as NC import qualified Network.TLS as NT import qualified Network.TLS.Extra as NT @@ -51,7 +107,7 @@ import qualified Polysemy.AtomicState as P import qualified Polysemy.Error as P import qualified Polysemy.Resource as P -import PyF +import PyF (fmt) import qualified System.X509 as X509 import TextShow (showt) import Prelude hiding (error) @@ -78,7 +134,7 @@ certStore <- X509.getSystemCertificateStore let clientParams = (NT.defaultParamsClient (T.unpack host) "443") - { NT.clientSupported = def{NT.supportedCiphers = NT.ciphersuite_default} + { NT.clientSupported = def {NT.supportedCiphers = NT.ciphersuite_default} , NT.clientShared = def { NT.sharedCAStore = certStore @@ -156,169 +212,167 @@ void outerloop void $ modifyGauge (subtract 1) activeShards debug "Shard shut down" - where - controlStream :: Shard -> TBMQueue ShardMsg -> IO () - controlStream shard outqueue = inner - where - q = shard ^. #cmdOut - inner = do - v <- UC.readChan q - r <- atomically $ tryWriteTBMQueue' outqueue (Control v) - when r inner + where + controlStream :: Shard -> TBMQueue ShardMsg -> IO () + controlStream shard outqueue = inner + where + q = shard ^. #cmdOut + inner = do + v <- UC.readChan q + r <- atomically $ tryWriteTBMQueue' outqueue (Control v) + when r inner - handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe T.Text) a) - handleWSException e = pure $ case fromException e of - Just (CloseRequest code _) - | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] -> - Left (ShutDownShard, Just . showt $ code) - e -> Left (RestartShard, Just . T.pack . show $ e) + handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe T.Text) a) + handleWSException e = pure $ case fromException e of + Just (CloseRequest code _) + | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] -> + Left (ShutDownShard, Just . showt $ code) + e -> Left (RestartShard, Just . T.pack . show $ e) - discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r () - discordStream ws outqueue = inner - where - inner = do - msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException + discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r () + discordStream ws outqueue = inner + where + inner = do + msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException - case msg of - Left (c, reason) -> do - whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|]) - P.embed . atomically $ writeTBMQueue outqueue (Control c) - Right msg' -> do - -- debug [fmt|Got msg: {msg'}|] - let decoded = A.eitherDecode msg' - r <- case decoded of - Right a -> - P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) - Left e -> do - error [fmt|Failed to decode: {e}|] - pure True - when r inner - outerloop :: ShardC r => Sem r () - outerloop = whileMFinalIO $ do - 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}|] + case msg of + Left (c, reason) -> do + whenJust reason (\r -> error [fmt|Shard closed with reason: {r}|]) + P.embed . atomically $ writeTBMQueue outqueue (Control c) + Right msg' -> do + -- debug [fmt|Got msg: {msg'}|] + let decoded = A.eitherDecode msg' + r <- case decoded of + Right a -> + P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) + Left e -> do + error [fmt|Failed to decode {e}: {msg'}|] + pure True + when r inner + outerloop :: ShardC r => Sem r () + outerloop = whileMFinalIO $ do + 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}|] - innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop + innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop - case innerLoopVal of - Just ShardFlowShutDown -> do - info "Shutting down shard" - pure False - Just ShardFlowRestart -> do - info "Restaring shard" - pure True - -- we restart normally when we loop + case innerLoopVal of + Just ShardFlowShutDown -> do + info "Shutting down shard" + pure False + Just ShardFlowRestart -> do + info "Restaring shard" + pure True + -- we restart normally when we loop - Nothing -> do - -- won't happen unless innerloop starts using a non-deterministic effect or connecting to the ws dies - info "Restarting shard (abnormal reasons?)" - pure True + Nothing -> do + -- won't happen unless innerloop starts using a non-deterministic effect or connecting to the ws dies + info "Restarting shard (abnormal reasons?)" + pure True - innerloop :: ShardC r => Connection -> Sem r ShardFlowControl - innerloop ws = do - debug "Entering inner loop of shard" + innerloop :: ShardC r => Connection -> Sem r ShardFlowControl + innerloop ws = do + debug "Entering inner loop of shard" - shard <- P.atomicGets (^. #shardS) - P.atomicModify' (#wsConn ?~ ws) + shard <- P.atomicGets (^. #shardS) + P.atomicModify' (#wsConn ?~ ws) - seqNum' <- P.atomicGets (^. #seqNum) - sessionID' <- P.atomicGets (^. #sessionID) + seqNum' <- P.atomicGets (^. #seqNum) + sessionID' <- P.atomicGets (^. #sessionID) - case (seqNum', sessionID') of - (Just n, Just s) -> do - debug [fmt|Resuming shard (sessionID: {s}, seq: {n})|] - sendToWs - ( Resume - ResumeData - { token = shard ^. #token - , sessionID = s - , seq = n - } - ) - _noActiveSession -> do - debug "Identifying shard" - sendToWs - ( Identify - IdentifyData - { token = shard ^. #token - , properties = - IdentifyProps - { browser = "Calamity: https://github.com/simmsb/calamity" - , device = "Calamity: https://github.com/simmsb/calamity" - } - , compress = False - , largeThreshold = 250 - , shard = - ( shard ^. #shardID - , shard ^. #shardCount - ) - , presence = shard ^. #initialStatus - , intents = shard ^. #intents - } - ) + case (seqNum', sessionID') of + (Just n, Just s) -> do + debug [fmt|Resuming shard (sessionID: {s}, seq: {n})|] + sendToWs + ( Resume + ResumeData + { token = shard ^. #token + , sessionID = s + , seq = n + } + ) + _noActiveSession -> do + debug "Identifying shard" + sendToWs + ( Identify + IdentifyData + { token = shard ^. #token + , properties = + IdentifyProps + { browser = "Calamity: https://github.com/simmsb/calamity" + , device = "Calamity: https://github.com/simmsb/calamity" + } + , compress = False + , largeThreshold = Nothing + , shard = + Just ( shard ^. #shardID , shard ^. #shardCount ) + , presence = shard ^. #initialStatus + , intents = shard ^. #intents + } + ) - result <- - P.resourceToIOFinal $ - P.bracket - (P.embed $ newTBMQueueIO 1) - (P.embed . atomically . closeTBMQueue) - ( \q -> do - debug "handling events now" - _controlThread <- P.async . P.embed $ controlStream shard q - _discordThread <- P.async $ discordStream ws q - P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do - -- only we close the queue - msg <- P.embed . atomically $ readTBMQueue q - handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg - ) + result <- + P.resourceToIOFinal $ + P.bracket + (P.embed $ newTBMQueueIO 1) + (P.embed . atomically . closeTBMQueue) + ( \q -> do + debug "handling events now" + _controlThread <- P.async . P.embed $ controlStream shard q + _discordThread <- P.async $ discordStream ws q + P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do + -- only we close the queue + msg <- P.embed . atomically $ readTBMQueue q + handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg + ) - debug "Exiting inner loop of shard" + debug "Exiting inner loop of shard" - P.atomicModify' (#wsConn .~ Nothing) - haltHeartBeat - pure result - handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r () - handleMsg (Discord msg) = case msg of - EvtDispatch sn data' -> do - -- trace $ "Handling event: ("+||data'||+")" - P.atomicModify' (#seqNum ?~ sn) + P.atomicModify' (#wsConn .~ Nothing) + haltHeartBeat + pure result + handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r () + handleMsg (Discord msg) = case msg of + EvtDispatch sn data' -> do + -- trace $ "Handling event: ("+||data'||+")" + P.atomicModify' (#seqNum ?~ sn) - case data' of - Ready rdata' -> - P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID)) - _NotReady -> pure () + case data' of + Ready rdata' -> + P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID)) + _NotReady -> pure () - shard <- P.atomicGets (^. #shardS) - P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data') - HeartBeatReq -> do - debug "Received heartbeat request" - sendHeartBeat - Reconnect -> do - debug "Being asked to restart by Discord" - P.throw ShardFlowRestart - InvalidSession resumable -> do - if resumable - then info "Received resumable invalid session" - else do - info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" - P.atomicModify' (#sessionID .~ Nothing) - P.atomicModify' (#seqNum .~ Nothing) - 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|] - 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})|] - sendToWs $ StatusUpdate data' - RestartShard -> P.throw ShardFlowRestart - ShutDownShard -> P.throw ShardFlowShutDown + shard <- P.atomicGets (^. #shardS) + P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data') + HeartBeatReq -> do + debug "Received heartbeat request" + sendHeartBeat + Reconnect -> do + debug "Being asked to restart by Discord" + P.throw ShardFlowRestart + InvalidSession resumable -> do + if resumable + then info "Received resumable invalid session" + else do + info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" + P.atomicModify' (#sessionID .~ Nothing) + P.atomicModify' (#seqNum .~ Nothing) + 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|] + 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})|] + sendToWs $ StatusUpdate data' + RestartShard -> P.throw ShardFlowRestart + ShutDownShard -> P.throw ShardFlowShutDown startHeartBeatLoop :: ShardC r => Int -> Sem r () startHeartBeatLoop interval = do diff --git a/Calamity/Gateway/Types.hs b/Calamity/Gateway/Types.hs --- a/Calamity/Gateway/Types.hs +++ b/Calamity/Gateway/Types.hs @@ -1,61 +1,63 @@ --- | Types for shards -module Calamity.Gateway.Types - ( ShardC - , ShardMsg(..) - , ReceivedDiscordMessage(..) - , SentDiscordMessage(..) - , DispatchType(..) - , IdentifyData(..) - , StatusUpdateData(..) - , ResumeData(..) - , RequestGuildMembersData(..) - , IdentifyProps(..) - , ControlMessage(..) - , ShardFlowControl(..) - , Shard(..) - , ShardState(..) ) where - -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Intents -import Calamity.Internal.AesonThings -import Calamity.Metrics.Eff -import Calamity.Types.LogEff -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Voice -import Calamity.Types.Model.Presence.Activity -import Calamity.Types.Model.User (StatusType) -import Calamity.Types.Snowflake - -import Control.Concurrent.Async -import Control.Concurrent.Chan.Unagi - -import Data.Aeson -import qualified Data.Aeson.Types as AT -import Data.Generics.Labels () -import Data.Maybe -import Data.Text ( Text ) - -import GHC.Generics +{-# LANGUAGE TemplateHaskell #-} -import Network.WebSockets.Connection ( Connection ) +-- | Types for shards +module Calamity.Gateway.Types ( + ShardC, + ShardMsg (..), + ReceivedDiscordMessage (..), + SentDiscordMessage (..), + DispatchType (..), + IdentifyData (..), + StatusUpdateData (..), + ResumeData (..), + RequestGuildMembersData (..), + IdentifyProps (..), + ControlMessage (..), + ShardFlowControl (..), + Shard (..), + ShardState (..), +) where -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.AtomicState as P -import qualified TextShow.Generic as TSG -import TextShow (TextShow) -import Control.Lens.Operators ((^?)) +import Calamity.Gateway.DispatchEvents +import Calamity.Gateway.Intents +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Metrics.Eff +import Calamity.Types.LogEff +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Presence.Activity +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice +import Calamity.Types.Snowflake +import Control.Concurrent.Async +import Control.Concurrent.Chan.Unagi +import qualified Data.Aeson as Aeson +import Data.Aeson.Optics import Data.Aeson.Types (parseMaybe) -import Control.Lens (Ixed(ix)) -import Data.Aeson.Lens +import qualified Data.Aeson.Types as AT +import Data.Text (Text) +import GHC.Generics +import Network.WebSockets.Connection (Connection) +import Optics +import qualified Polysemy as P +import qualified Polysemy.Async as P +import qualified Polysemy.AtomicState as P -type ShardC r = (P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO, - P.Async, MetricEff] r) +type ShardC r = + ( P.Members + '[ LogEff + , P.AtomicState ShardState + , P.Embed IO + , P.Final IO + , P.Async + , MetricEff + ] + r + ) data ShardMsg = Discord ReceivedDiscordMessage | Control ControlMessage - deriving ( Show, Generic ) + deriving (Show) data ReceivedDiscordMessage = EvtDispatch Int !DispatchData @@ -64,86 +66,89 @@ | InvalidSession Bool | Hello Int | HeartBeatAck - deriving ( Show, Generic ) + deriving (Show) -instance FromJSON ReceivedDiscordMessage where - parseJSON = withObject "ReceivedDiscordMessage" $ \v -> do - op :: Int <- v .: "op" +instance Aeson.FromJSON ReceivedDiscordMessage where + parseJSON = Aeson.withObject "ReceivedDiscordMessage" $ \v -> do + op :: Int <- v Aeson..: "op" case op of - 0 -> do - d <- v .: "d" - t <- v .: "t" - s <- v .: "s" + 0 -> do + d <- v Aeson..: "d" + t <- v Aeson..: "t" + s <- v Aeson..: "s" EvtDispatch s <$> parseDispatchData t d - - 1 -> pure HeartBeatReq - - 7 -> pure Reconnect - - 9 -> InvalidSession <$> v .: "d" - - 10 -> Hello <$> do - d <- v .: "d" - d .: "heartbeat_interval" - + 1 -> pure HeartBeatReq + 7 -> pure Reconnect + 9 -> InvalidSession <$> v Aeson..: "d" + 10 -> + Hello <$> do + d <- v Aeson..: "d" + d Aeson..: "heartbeat_interval" 11 -> pure HeartBeatAck - - _ -> fail $ "invalid opcode: " <> show op + _ -> fail $ "invalid opcode: " <> show op -parseDispatchData :: DispatchType -> Value -> AT.Parser DispatchData -parseDispatchData READY data' = Ready <$> parseJSON data' -parseDispatchData RESUMED _ = pure Resumed -parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> parseJSON data' -parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> parseJSON data' -parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> parseJSON data' -parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> parseJSON data' -parseDispatchData GUILD_CREATE data' = GuildCreate <$> parseJSON data' -parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> parseJSON data' -parseDispatchData GUILD_DELETE data' = GuildDelete <$> parseJSON data' -parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> parseJSON data' -parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> parseJSON data' -parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> parseJSON data' -parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> parseJSON data' -parseDispatchData GUILD_MEMBER_ADD data' = do - guildID <- withObject "GuildMemberAdd.guild_id" (.: "guild_id") data' - GuildMemberAdd guildID <$> parseJSON data' -parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> parseJSON data' -parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> parseJSON data' -parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> parseJSON data' -parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> parseJSON data' -parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> parseJSON data' -parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> parseJSON data' -parseDispatchData INVITE_CREATE data' = InviteCreate <$> parseJSON data' -parseDispatchData INVITE_DELETE data' = InviteDelete <$> parseJSON data' -parseDispatchData MESSAGE_CREATE data' = do - message <- parseJSON data' - let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do - userObject :: Object <- o .: "author" - memberObject :: Object <- o .: "member" - parseJSON $ Object (memberObject <> "user" .= userObject)) data' +parseDispatchData :: DispatchType -> Aeson.Value -> AT.Parser DispatchData +parseDispatchData READY data' = Ready <$> Aeson.parseJSON data' +parseDispatchData RESUMED _ = pure Resumed +parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> Aeson.parseJSON data' +parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> Aeson.parseJSON data' +parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> Aeson.parseJSON data' +parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_CREATE data' = GuildCreate <$> Aeson.parseJSON data' +parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_DELETE data' = GuildDelete <$> Aeson.parseJSON data' +parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> Aeson.parseJSON data' +parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> Aeson.parseJSON data' +parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBER_ADD data' = do + guildID <- Aeson.withObject "GuildMemberAdd.guild_id" (Aeson..: "guild_id") data' + GuildMemberAdd guildID <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> Aeson.parseJSON data' +parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> Aeson.parseJSON data' +parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> Aeson.parseJSON data' +parseDispatchData INVITE_CREATE data' = InviteCreate <$> Aeson.parseJSON data' +parseDispatchData INVITE_DELETE data' = InviteDelete <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_CREATE data' = do + message <- Aeson.parseJSON data' + let member = + parseMaybe + ( Aeson.withObject "MessageCreate.member" $ \o -> do + userObject :: Aeson.Object <- o Aeson..: "author" + memberObject :: Aeson.Object <- o Aeson..: "member" + Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject) + ) + data' - let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author" + let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author" pure $ MessageCreate message user member -parseDispatchData MESSAGE_UPDATE data' = do - message <- parseJSON data' - let member = parseMaybe (withObject "MessageCreate.member" $ \o -> do - userObject :: Object <- o .: "author" - memberObject :: Object <- o .: "member" - parseJSON $ Object (memberObject <> "user" .= userObject)) data' - let user = parseMaybe parseJSON =<< data' ^? _Object . ix "author" +parseDispatchData MESSAGE_UPDATE data' = do + message <- Aeson.parseJSON data' + let member = + parseMaybe + ( Aeson.withObject "MessageCreate.member" $ \o -> do + userObject :: Aeson.Object <- o Aeson..: "author" + memberObject :: Aeson.Object <- o Aeson..: "member" + Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject) + ) + data' + let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author" pure $ MessageUpdate message user member -parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data' -parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> parseJSON data' -parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> parseJSON data' -parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> parseJSON data' -parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> parseJSON data' -parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> parseJSON data' -parseDispatchData TYPING_START data' = TypingStart <$> parseJSON data' -parseDispatchData USER_UPDATE data' = UserUpdate <$> parseJSON data' -parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> parseJSON data' -parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> parseJSON data' -parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> parseJSON data' -parseDispatchData INTERACTION_CREATE data' = InteractionCreate <$> parseJSON data' +parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> Aeson.parseJSON data' +parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> Aeson.parseJSON data' +parseDispatchData TYPING_START data' = TypingStart <$> Aeson.parseJSON data' +parseDispatchData USER_UPDATE data' = UserUpdate <$> Aeson.parseJSON data' +parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> Aeson.parseJSON data' +parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> Aeson.parseJSON data' +parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> Aeson.parseJSON data' +parseDispatchData INTERACTION_CREATE data' = InteractionCreate <$> Aeson.parseJSON data' data SentDiscordMessage = StatusUpdate StatusUpdateData @@ -152,32 +157,22 @@ | VoiceStatusUpdate VoiceState | Resume ResumeData | RequestGuildMembers RequestGuildMembersData - deriving ( Show, Generic ) - -instance ToJSON SentDiscordMessage where - toJSON (HeartBeat data') = object ["op" .= (1 :: Int), "d" .= data'] - - toJSON (Identify data') = object ["op" .= (2 :: Int), "d" .= data'] - - toJSON (StatusUpdate data') = object ["op" .= (3 :: Int), "d" .= data'] - - toJSON (VoiceStatusUpdate data') = object ["op" .= (4 :: Int), "d" .= data'] - - toJSON (Resume data') = object ["op" .= (6 :: Int), "d" .= data'] - - toJSON (RequestGuildMembers data') = object ["op" .= (8 :: Int), "d" .= data'] - - toEncoding (HeartBeat data') = pairs ("op" .= (1 :: Int) <> "d" .= data') - - toEncoding (Identify data') = pairs ("op" .= (2 :: Int) <> "d" .= data') - - toEncoding (StatusUpdate data') = pairs ("op" .= (3 :: Int) <> "d" .= data') - - toEncoding (VoiceStatusUpdate data') = pairs ("op" .= (4 :: Int) <> "d" .= data') + deriving (Show) - toEncoding (Resume data') = pairs ("op" .= (6 :: Int) <> "d" .= data') +instance Aeson.ToJSON SentDiscordMessage where + toJSON (HeartBeat data') = Aeson.object ["op" Aeson..= (1 :: Int), "d" Aeson..= data'] + toJSON (Identify data') = Aeson.object ["op" Aeson..= (2 :: Int), "d" Aeson..= data'] + toJSON (StatusUpdate data') = Aeson.object ["op" Aeson..= (3 :: Int), "d" Aeson..= data'] + toJSON (VoiceStatusUpdate data') = Aeson.object ["op" Aeson..= (4 :: Int), "d" Aeson..= data'] + toJSON (Resume data') = Aeson.object ["op" Aeson..= (6 :: Int), "d" Aeson..= data'] + toJSON (RequestGuildMembers data') = Aeson.object ["op" Aeson..= (8 :: Int), "d" Aeson..= data'] - toEncoding (RequestGuildMembers data') = pairs ("op" .= (8 :: Int) <> "d" .= data') + toEncoding (HeartBeat data') = Aeson.pairs ("op" Aeson..= (1 :: Int) <> "d" Aeson..= data') + toEncoding (Identify data') = Aeson.pairs ("op" Aeson..= (2 :: Int) <> "d" Aeson..= data') + toEncoding (StatusUpdate data') = Aeson.pairs ("op" Aeson..= (3 :: Int) <> "d" Aeson..= data') + toEncoding (VoiceStatusUpdate data') = Aeson.pairs ("op" Aeson..= (4 :: Int) <> "d" Aeson..= data') + toEncoding (Resume data') = Aeson.pairs ("op" Aeson..= (6 :: Int) <> "d" Aeson..= data') + toEncoding (RequestGuildMembers data') = Aeson.pairs ("op" Aeson..= (8 :: Int) <> "d" Aeson..= data') -- Thanks sbrg: -- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs @@ -218,89 +213,126 @@ | VOICE_SERVER_UPDATE | WEBHOOKS_UPDATE | INTERACTION_CREATE - deriving ( Show, Eq, Enum, Generic ) - deriving anyclass ( ToJSON, FromJSON ) + deriving (Show, Eq, Enum, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) data IdentifyData = IdentifyData - { token :: Text - , properties :: IdentifyProps - , compress :: Bool - , largeThreshold :: Int - , shard :: (Int, Int) - , presence :: Maybe StatusUpdateData - , intents :: Intents + { token :: Text + , properties :: IdentifyProps + , compress :: Bool + , largeThreshold :: Maybe Int + , shard :: Maybe (Int, Int) + , presence :: Maybe StatusUpdateData + , intents :: Intents } - deriving ( Show, Generic ) - deriving ToJSON via CalamityJSON IdentifyData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON IdentifyData +instance CalamityToJSON' IdentifyData where + toPairs IdentifyData {..} = + [ "token" .= token + , "properties" .= properties + , "compress" .= compress + , "large_threshold" .?= largeThreshold + , "shard" .?= shard + , "presence" .?= presence + , "intents" .= intents + ] + data StatusUpdateData = StatusUpdateData - { since :: Maybe Integer - , game :: Maybe Activity + { since :: Maybe Integer + , activities :: [Activity] , status :: StatusType - , afk :: Bool + , afk :: Bool } - deriving ( Show, Generic ) - deriving ToJSON via CalamityJSONKeepNothing StatusUpdateData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON StatusUpdateData +instance CalamityToJSON' StatusUpdateData where + toPairs StatusUpdateData {..} = + [ "since" .= since + , "activities" .= activities + , "status" .= status + , "afk" .= afk + ] + data ResumeData = ResumeData - { token :: Text + { token :: Text , sessionID :: Text - , seq :: Int + , seq :: Int } - deriving ( Show, Generic ) - deriving ( ToJSON, FromJSON ) via CalamityJSON ResumeData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ResumeData +instance CalamityToJSON' ResumeData where + toPairs ResumeData {..} = + [ "token" .= token + , "session_id" .= sessionID + , "seq" .= seq + ] + data RequestGuildMembersData = RequestGuildMembersData { guildID :: Snowflake Guild - , query :: Maybe Text - , limit :: Maybe Int + , query :: Maybe Text + , limit :: Int + , presences :: Maybe Bool + , userIDs :: Maybe [Snowflake User] + , nonce :: Maybe Text } - deriving ( Show, Generic ) + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON RequestGuildMembersData -instance ToJSON RequestGuildMembersData where - toJSON RequestGuildMembersData { guildID, query, limit } = - object ["guild_id" .= guildID, "query" .= fromMaybe "" query, "limit" .= fromMaybe 0 limit] +instance CalamityToJSON' RequestGuildMembersData where + toPairs RequestGuildMembersData {..} = + [ "guild_id" .= guildID + , "query" .?= query + , "limit" .= limit + , "presences" .?= presences + , "user_ids" .?= userIDs + , "nonce" .?= nonce + ] data IdentifyProps = IdentifyProps { browser :: Text - , device :: Text + , device :: Text } - deriving ( Show, Generic ) + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON IdentifyProps -instance ToJSON IdentifyProps where - toJSON IdentifyProps { browser, device } = object ["$browser" .= browser, "$device" .= device] +instance CalamityToJSON' IdentifyProps where + toPairs IdentifyProps {..} = ["$browser" .= browser, "$device" .= device] data ControlMessage = RestartShard | ShutDownShard | SendPresence StatusUpdateData - deriving ( Show, Generic ) + deriving (Show) data ShardFlowControl = ShardFlowRestart | ShardFlowShutDown - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ShardFlowControl + deriving (Show) data Shard = Shard - { shardID :: Int - , shardCount :: Int - , gateway :: Text - , evtIn :: InChan CalamityEvent - , cmdOut :: OutChan ControlMessage - , token :: Text + { shardID :: Int + , shardCount :: Int + , gateway :: Text + , evtIn :: InChan CalamityEvent + , cmdOut :: OutChan ControlMessage + , token :: Text , initialStatus :: Maybe StatusUpdateData - , intents :: Intents + , intents :: Intents } - deriving ( Generic ) data ShardState = ShardState - { shardS :: Shard - , seqNum :: Maybe Int - , hbThread :: Maybe (Async (Maybe ())) + { shardS :: Shard + , seqNum :: Maybe Int + , hbThread :: Maybe (Async (Maybe ())) , hbResponse :: Bool - , wsHost :: Maybe Text - , sessionID :: Maybe Text - , wsConn :: Maybe Connection + , wsHost :: Maybe Text + , sessionID :: Maybe Text + , wsConn :: Maybe Connection } - deriving ( Generic ) + +$(makeFieldLabelsNoPrefix ''Shard) +$(makeFieldLabelsNoPrefix ''ShardState) diff --git a/Calamity/HTTP/AuditLog.hs b/Calamity/HTTP/AuditLog.hs --- a/Calamity/HTTP/AuditLog.hs +++ b/Calamity/HTTP/AuditLog.hs @@ -6,16 +6,11 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.Utils () import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake - -import Control.Lens - import Data.Default.Class - -import GHC.Generics +import Data.Function ((&)) data GetAuditLogOptions = GetAuditLogOptions { userID :: Maybe (Snowflake User) @@ -23,8 +18,11 @@ , before :: Maybe (Snowflake AuditLogEntry) , limit :: Maybe Integer } - deriving (Show, Generic, Default) + deriving (Show) +instance Default GetAuditLogOptions where + def = GetAuditLogOptions Nothing Nothing Nothing Nothing + data AuditLogRequest a where GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog @@ -36,7 +34,7 @@ & giveID gid & buildRoute - action (GetAuditLog _ GetAuditLogOptions{userID, actionType, before, limit}) = + action (GetAuditLog _ GetAuditLogOptions {userID, actionType, before, limit}) = getWithP ( "user_id" =:? (fromSnowflake <$> userID) <> "action_type" =:? (fromEnum <$> actionType) diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs --- a/Calamity/HTTP/Channel.hs +++ b/Calamity/HTTP/Channel.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Channel endpoints module Calamity.HTTP.Channel ( ChannelRequest (..), @@ -21,7 +23,7 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji (RawEmoji (..)) import Calamity.Types.Model.Guild.Invite (Invite) @@ -29,8 +31,7 @@ import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.Lens hiding ((.=)) -import Data.Aeson +import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as K import Data.ByteString.Lazy (ByteString) import Data.Default.Class @@ -38,10 +39,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Word -import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime +import Optics import PyF import TextShow @@ -50,7 +51,7 @@ , description :: Maybe Text , content :: ByteString } - deriving (Show, Generic) + deriving (Show) data CreateMessageOptions = CreateMessageOptions { content :: Maybe Text @@ -62,16 +63,26 @@ , messageReference :: Maybe MessageReference , components :: Maybe [Component] } - deriving (Show, Generic, Default) + deriving (Show) +instance Default CreateMessageOptions where + def = CreateMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + data CreateMessageAttachmentJson = CreateMessageAttachmentJson { id :: Int , filename :: Text , description :: Maybe Text } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson +instance CalamityToJSON' CreateMessageAttachmentJson where + toPairs CreateMessageAttachmentJson {..} = + [ "filename" .= filename + , "description" .?= description + , "id" .= id + ] + data CreateMessageJson = CreateMessageJson { content :: Maybe Text , nonce :: Maybe Text @@ -82,19 +93,31 @@ , components :: Maybe [Component] , attachments :: Maybe [CreateMessageAttachmentJson] } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateMessageJson + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageJson +instance CalamityToJSON' CreateMessageJson where + toPairs CreateMessageJson {..} = + [ "content" .?= content + , "nonce" .?= nonce + , "tts" .?= tts + , "embeds" .?= embeds + , "allowed_mentions" .?= allowedMentions + , "message_reference" .?= messageReference + , "components" .?= components + , "attachments" .?= attachments + ] + data AllowedMentionType = AllowedMentionRoles | AllowedMentionUsers | AllowedMentionEveryone - deriving (Show, Generic) + deriving (Show) -instance ToJSON AllowedMentionType where - toJSON AllowedMentionRoles = String "roles" - toJSON AllowedMentionUsers = String "users" - toJSON AllowedMentionEveryone = String "everyone" +instance Aeson.ToJSON AllowedMentionType where + toJSON AllowedMentionRoles = Aeson.String "roles" + toJSON AllowedMentionUsers = Aeson.String "users" + toJSON AllowedMentionEveryone = Aeson.String "everyone" data AllowedMentions = AllowedMentions { parse :: [AllowedMentionType] @@ -102,9 +125,17 @@ , users :: [Snowflake User] , repliedUser :: Bool } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON AllowedMentions + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON AllowedMentions +instance CalamityToJSON' AllowedMentions where + toPairs AllowedMentions {..} = + [ "parse" .= parse + , "roles" .= roles + , "users" .= users + , "replied_user" .= repliedUser + ] + instance Default AllowedMentions where def = AllowedMentions def def def False @@ -125,24 +156,24 @@ >>> encode $ editMessageContent (Just "test") <> editMessageFlags Nothing "{\"nick\":\"test\",\"deaf\":null}" -} -newtype EditMessageData = EditMessageData Object - deriving (Show, Generic) - deriving newtype (ToJSON, Semigroup, Monoid) +newtype EditMessageData = EditMessageData Aeson.Object + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Semigroup, Monoid) editMessageContent :: Maybe Text -> EditMessageData -editMessageContent v = EditMessageData $ K.fromList [("content", toJSON v)] +editMessageContent v = EditMessageData $ K.fromList [("content", Aeson.toJSON v)] editMessageEmbeds :: [Embed] -> EditMessageData -editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", toJSON v)] +editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", Aeson.toJSON v)] editMessageFlags :: Maybe Word64 -> EditMessageData -editMessageFlags v = EditMessageData $ K.fromList [("flags", toJSON v)] +editMessageFlags v = EditMessageData $ K.fromList [("flags", Aeson.toJSON v)] editMessageAllowedMentions :: Maybe AllowedMentions -> EditMessageData -editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", toJSON v)] +editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", Aeson.toJSON v)] editMessageComponents :: [Component] -> EditMessageData -editMessageComponents v = EditMessageData $ K.fromList [("components", toJSON v)] +editMessageComponents v = EditMessageData $ K.fromList [("components", Aeson.toJSON v)] data ChannelUpdate = ChannelUpdate { name :: Maybe Text @@ -155,9 +186,25 @@ , permissionOverwrites :: Maybe [Overwrite] , parentID :: Maybe (Snowflake Channel) } - deriving (Generic, Show, Default) - deriving (ToJSON) via CalamityJSON ChannelUpdate + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelUpdate +instance Default ChannelUpdate where + def = ChannelUpdate Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance CalamityToJSON' ChannelUpdate where + toPairs ChannelUpdate {..} = + [ "name" .?= name + , "position" .?= position + , "topic" .?= topic + , "nsfw" .?= nsfw + , "rate_limit_per_user" .?= rateLimitPerUser + , "bitrate" .?= bitrate + , "user_limit" .?= userLimit + , "permission_overwrites" .?= permissionOverwrites + , "parent_id" .?= parentID + ] + data ChannelMessagesFilter = ChannelMessagesAround { around :: Snowflake Message @@ -168,37 +215,73 @@ | ChannelMessagesAfter { after :: Snowflake Message } - deriving (Generic, Show) - deriving (ToJSON) via CalamityJSON ChannelMessagesFilter + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelMessagesFilter +instance CalamityToJSON' ChannelMessagesFilter where + toPairs ChannelMessagesAround {around} = ["around" .= around] + toPairs ChannelMessagesBefore {before} = ["before" .= before] + toPairs ChannelMessagesAfter {after} = ["after" .= after] + newtype ChannelMessagesLimit = ChannelMessagesLimit { limit :: Integer } - deriving (Generic, Show) + deriving stock (Show) data GetReactionsOptions = GetReactionsOptions { before :: Maybe (Snowflake User) , after :: Maybe (Snowflake User) , limit :: Maybe Integer } - deriving (Show, Generic, Default) + deriving (Show) +instance Default GetReactionsOptions where + def = GetReactionsOptions Nothing Nothing Nothing + data CreateChannelInviteOptions = CreateChannelInviteOptions { maxAge :: Maybe Int , maxUses :: Maybe Int , temporary :: Maybe Bool , unique :: Maybe Bool } - deriving (Show, Generic, Default) - deriving (ToJSON) via CalamityJSON CreateChannelInviteOptions + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateChannelInviteOptions +instance Default CreateChannelInviteOptions where + def = CreateChannelInviteOptions Nothing Nothing Nothing Nothing + +instance CalamityToJSON' CreateChannelInviteOptions where + toPairs CreateChannelInviteOptions {..} = + [ "max_age" .?= maxAge + , "max_uses" .?= maxUses + , "temporary" .?= temporary + , "unique" .?= unique + ] + data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions { accessToken :: Text , nick :: Text } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON GroupDMAddRecipientOptions + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON GroupDMAddRecipientOptions +instance CalamityToJSON' GroupDMAddRecipientOptions where + toPairs GroupDMAddRecipientOptions {..} = + [ "access_token" .= accessToken + , "nick" .= nick + ] + +$(makeFieldLabelsNoPrefix ''CreateMessageAttachment) +$(makeFieldLabelsNoPrefix ''CreateMessageOptions) +$(makeFieldLabelsNoPrefix ''CreateMessageAttachmentJson) +$(makeFieldLabelsNoPrefix ''AllowedMentions) +$(makeFieldLabelsNoPrefix ''ChannelUpdate) +$(makeFieldLabelsNoPrefix ''ChannelMessagesFilter) +$(makeFieldLabelsNoPrefix ''ChannelMessagesLimit) +$(makeFieldLabelsNoPrefix ''GetReactionsOptions) +$(makeFieldLabelsNoPrefix ''CreateChannelInviteOptions) +$(makeFieldLabelsNoPrefix ''GroupDMAddRecipientOptions) + data ChannelRequest a where CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message CrosspostMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message @@ -354,19 +437,19 @@ , components = cm ^. #components , attachments = attachments } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) postWith' body u o action (CrosspostMessage _ _) = postEmpty action (GetChannel _) = getWith action (ModifyChannel _ p) = patchWith' (ReqBodyJson p) action (DeleteChannel _) = deleteWith action (GetChannelMessages _ (Just (ChannelMessagesAround (fromSnowflake -> a))) l) = - getWithP ("around" =: a <> "limit" =:? (l ^? _Just . #limit)) + getWithP ("around" =: a <> "limit" =:? (l ^? _Just % #limit)) action (GetChannelMessages _ (Just (ChannelMessagesBefore (fromSnowflake -> a))) l) = - getWithP ("before" =: a <> "limit" =:? (l ^? _Just . #limit)) + getWithP ("before" =: a <> "limit" =:? (l ^? _Just % #limit)) action (GetChannelMessages _ (Just (ChannelMessagesAfter (fromSnowflake -> a))) l) = - getWithP ("after" =: a <> "limit" =:? (l ^? _Just . #limit)) - action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just . #limit)) + getWithP ("after" =: a <> "limit" =:? (l ^? _Just % #limit)) + action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just % #limit)) action (GetMessage _ _) = getWith action CreateReaction {} = putEmpty action DeleteOwnReaction {} = deleteWith @@ -380,7 +463,7 @@ action (DeleteAllReactions _ _) = deleteWith action (EditMessage _ _ o) = patchWith' (ReqBodyJson o) action (DeleteMessage _ _) = deleteWith - action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ object ["messages" .= ids]) + action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ Aeson.object ["messages" Aeson..= ids]) action (GetChannelInvites _) = getWith action (CreateChannelInvite _ o) = postWith' (ReqBodyJson o) action (EditChannelPermissions _ o) = putWith' (ReqBodyJson o) @@ -391,3 +474,4 @@ action (DeletePinnedMessage _ _) = deleteWith action (GroupDMAddRecipient _ _ o) = putWith' (ReqBodyJson o) action (GroupDMRemoveRecipient _ _) = deleteWith + diff --git a/Calamity/HTTP/Emoji.hs b/Calamity/HTTP/Emoji.hs --- a/Calamity/HTTP/Emoji.hs +++ b/Calamity/HTTP/Emoji.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Emoji endpoints module Calamity.HTTP.Emoji ( EmojiRequest (..), @@ -7,34 +9,43 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) import Calamity.Types.Model.Guild import Calamity.Types.Snowflake - -import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Function import Data.Text (Text) - -import GHC.Generics - import Network.HTTP.Req +import Optics.TH data CreateGuildEmojiOptions = CreateGuildEmojiOptions { name :: Text , image :: Text , roles :: [Snowflake Role] } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateGuildEmojiOptions + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateGuildEmojiOptions +instance CalamityToJSON' CreateGuildEmojiOptions where + toPairs CreateGuildEmojiOptions {..} = + [ "name" .= name + , "image" .= image + , "roles" .= roles + ] + data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions { name :: Text , roles :: [Snowflake Role] } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON ModifyGuildEmojiOptions + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildEmojiOptions +instance CalamityToJSON' ModifyGuildEmojiOptions where + toPairs ModifyGuildEmojiOptions {..} = + [ "name" .= name + , "roles" .= roles + ] + data EmojiRequest a where ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji] GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji @@ -68,3 +79,6 @@ action (CreateGuildEmoji _ o) = postWith' (ReqBodyJson o) action (ModifyGuildEmoji _ _ o) = patchWith' (ReqBodyJson o) action (DeleteGuildEmoji _ _) = deleteWith + +$(makeFieldLabelsNoPrefix ''CreateGuildEmojiOptions) +$(makeFieldLabelsNoPrefix ''ModifyGuildEmojiOptions) diff --git a/Calamity/HTTP/Guild.hs b/Calamity/HTTP/Guild.hs --- a/Calamity/HTTP/Guild.hs +++ b/Calamity/HTTP/Guild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Guild endpoints module Calamity.HTTP.Guild ( GuildRequest (..), @@ -7,14 +9,14 @@ ChannelPosition (..), ListMembersOptions (..), AddGuildMemberData (..), - ModifyGuildMemberData (..), + ModifyGuildMemberData, modifyGuildMemberNick, modifyGuildMemberRoles, modifyGuildMemberMute, modifyGuildMemberDeaf, modifyGuildMemberChannelID, CreateGuildBanData (..), - ModifyGuildRoleData (..), + ModifyGuildRoleData, modifyGuildRoleName, modifyGuildRolePermissions, modifyGuildRoleColour, @@ -25,23 +27,20 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings import Calamity.Internal.IntColour +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake -import Control.Lens hiding ((.=)) -import Data.Aeson +import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as K -import Data.Aeson.Lens import Data.Colour (Colour) import Data.Default.Class import Data.Text (Text) -import GHC.Generics import Network.HTTP.Req -import TextShow +import Optics data CreateGuildData = CreateGuildData { name :: Text @@ -53,9 +52,21 @@ , roles :: [Role] , channels :: [Partial Channel] } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateGuildData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateGuildData +instance CalamityToJSON' CreateGuildData where + toPairs CreateGuildData {..} = + [ "name" .= name + , "region" .= region + , "icon" .= icon + , "verification_level" .= verificationLevel + , "default_message_notifications" .= defaultMessageNotifications + , "explicit_content_filter" .= explicitContentFilter + , "roles" .= roles + , "channels" .= channels + ] + data ModifyGuildData = ModifyGuildData { name :: Maybe Text , region :: Maybe Text @@ -70,9 +81,41 @@ , banner :: Maybe Text , systemChannelID :: Maybe (Snowflake GuildChannel) } - deriving (Show, Generic, Default) - deriving (ToJSON) via CalamityJSON ModifyGuildData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildData +instance Default ModifyGuildData where + def = + ModifyGuildData + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +-- TODO: Make this work properly, a la modifyguildmember +instance CalamityToJSON' ModifyGuildData where + toPairs ModifyGuildData {..} = + [ "name" .?= name + , "region" .?= region + , "icon" .?= icon + , "verification_level" .?= verificationLevel + , "default_message_notifications" .?= defaultMessageNotifications + , "explicit_content_filter" .?= explicitContentFilter + , "afk_timeout" .?= afkTimeout + , "owner_id" .?= ownerID + , "splash" .?= splash + , "banner" .?= banner + , "system_channel_id" .?= systemChannelID + ] + data ChannelCreateData = ChannelCreateData { name :: Text , type_ :: Maybe ChannelType @@ -85,28 +128,69 @@ , parentID :: Maybe (Snowflake Category) , nsfw :: Maybe Bool } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON ChannelCreateData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelCreateData +instance CalamityToJSON' ChannelCreateData where + toPairs ChannelCreateData {..} = + [ "name" .= name + , "type" .?= type_ + , "topic" .?= topic + , "bitrate" .?= bitrate + , "user_limit" .?= userLimit + , "rate_limit_per_user" .?= rateLimitPerUser + , "position" .?= position + , "permission_overwrites" .?= permissionOverwrites + , "parent_id" .?= parentID + , "nsfw" .?= nsfw + ] + data ChannelPosition = ChannelPosition { id :: Snowflake GuildChannel , position :: Maybe Integer + , lockPermissions :: Maybe Bool + , parentID :: Snowflake GuildChannel } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON ChannelPosition + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelPosition +instance CalamityToJSON' ChannelPosition where + toPairs ChannelPosition {..} = + [ "id" .= id + , "position" .= position + , "lock_permissions" .= lockPermissions + , "parent_id" .= parentID + ] + data ListMembersOptions = ListMembersOptions { limit :: Maybe Integer , after :: Maybe (Snowflake User) } - deriving (Show, Generic, Default) + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ListMembersOptions +instance Default ListMembersOptions where + def = ListMembersOptions Nothing Nothing + +instance CalamityToJSON' ListMembersOptions where + toPairs ListMembersOptions {..} = + [ "limit" .?= limit + , "after" .?= after + ] + data SearchMembersOptions = SearchMembersOptions { limit :: Maybe Integer , query :: Text } - deriving (Show, Generic) + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON SearchMembersOptions +instance CalamityToJSON' SearchMembersOptions where + toPairs SearchMembersOptions {..} = + [ "limit" .?= limit + , "query" .= query + ] + data AddGuildMemberData = AddGuildMemberData { accessToken :: Text , nick :: Maybe Text @@ -114,87 +198,108 @@ , mute :: Maybe Bool , deaf :: Maybe Bool } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON AddGuildMemberData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON AddGuildMemberData +instance CalamityToJSON' AddGuildMemberData where + toPairs AddGuildMemberData {..} = + [ "access_token" .= accessToken + , "nick" .?= nick + , "roles" .?= roles + , "mute" .?= mute + , "deaf" .?= deaf + ] + {- | Parameters to the Modify Guild Member endpoint. Use the provided methods (@modifyGuildMemberX@) to create a value with the - field set, use the Semigroup instance to union the values. + field set, use the Semigroup instance to combine modifications. ==== Examples >>> encode $ modifyGuildMemberNick (Just "test") <> modifyGuildMemberDeaf Nothing "{\"nick\":\"test\",\"deaf\":null}" -} -newtype ModifyGuildMemberData = ModifyGuildMemberData Object - deriving (Show, Generic) - deriving newtype (ToJSON, Semigroup, Monoid) +newtype ModifyGuildMemberData = ModifyGuildMemberData Aeson.Object + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Semigroup, Monoid) modifyGuildMemberNick :: Maybe Text -> ModifyGuildMemberData -modifyGuildMemberNick v = ModifyGuildMemberData $ K.fromList [("nick", toJSON v)] +modifyGuildMemberNick v = ModifyGuildMemberData $ K.fromList [("nick", Aeson.toJSON v)] modifyGuildMemberRoles :: Maybe [Snowflake Role] -> ModifyGuildMemberData -modifyGuildMemberRoles v = ModifyGuildMemberData $ K.fromList [("roles", toJSON v)] +modifyGuildMemberRoles v = ModifyGuildMemberData $ K.fromList [("roles", Aeson.toJSON v)] modifyGuildMemberMute :: Maybe Bool -> ModifyGuildMemberData -modifyGuildMemberMute v = ModifyGuildMemberData $ K.fromList [("mute", toJSON v)] +modifyGuildMemberMute v = ModifyGuildMemberData $ K.fromList [("mute", Aeson.toJSON v)] modifyGuildMemberDeaf :: Maybe Bool -> ModifyGuildMemberData -modifyGuildMemberDeaf v = ModifyGuildMemberData $ K.fromList [("deaf", toJSON v)] +modifyGuildMemberDeaf v = ModifyGuildMemberData $ K.fromList [("deaf", Aeson.toJSON v)] modifyGuildMemberChannelID :: Maybe (Snowflake VoiceChannel) -> ModifyGuildMemberData -modifyGuildMemberChannelID v = ModifyGuildMemberData $ K.fromList [("channel_id", toJSON v)] +modifyGuildMemberChannelID v = ModifyGuildMemberData $ K.fromList [("channel_id", Aeson.toJSON v)] data GetGuildBansOptions = GetGuildBansOptions { limit :: Maybe Int , before :: Maybe Int , after :: Maybe Int } - deriving (Show, Generic, Default) + deriving (Show) +instance Default GetGuildBansOptions where + def = GetGuildBansOptions Nothing Nothing Nothing + data CreateGuildBanData = CreateGuildBanData { deleteMessageDays :: Maybe Integer , reason :: Maybe Text } - deriving (Show, Generic, Default) + deriving (Show) +instance Default CreateGuildBanData where + def = CreateGuildBanData Nothing Nothing + {- | Parameters to the Modify Guild Role endpoint. Use the provided methods (@modifyGuildRoleX@) to create a value with the - field set, use the Semigroup instance to union the values. + field set, use the Semigroup instance to combine parameters. ==== Examples >>> encode $ modifyGuildRoleName (Just "test") <> modifyGuildRolePermissions Nothing "{\"name\":\"test\",\"permissions\":null}" -} -newtype ModifyGuildRoleData = ModifyGuildRoleData Object - deriving (Show, Generic) - deriving newtype (ToJSON, Semigroup, Monoid) +newtype ModifyGuildRoleData = ModifyGuildRoleData Aeson.Object + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Semigroup, Monoid) modifyGuildRoleName :: Maybe Text -> ModifyGuildRoleData -modifyGuildRoleName v = ModifyGuildRoleData $ K.fromList [("name", toJSON v)] +modifyGuildRoleName v = ModifyGuildRoleData $ K.fromList [("name", Aeson.toJSON v)] modifyGuildRolePermissions :: Maybe Permissions -> ModifyGuildRoleData -modifyGuildRolePermissions v = ModifyGuildRoleData $ K.fromList [("permissions", toJSON v)] +modifyGuildRolePermissions v = ModifyGuildRoleData $ K.fromList [("permissions", Aeson.toJSON v)] modifyGuildRoleColour :: Maybe (Colour Double) -> ModifyGuildRoleData -modifyGuildRoleColour v = ModifyGuildRoleData $ K.fromList [("colour", toJSON (IntColour <$> v))] +modifyGuildRoleColour v = ModifyGuildRoleData $ K.fromList [("colour", Aeson.toJSON (IntColour <$> v))] modifyGuildRoleHoist :: Maybe Bool -> ModifyGuildRoleData -modifyGuildRoleHoist v = ModifyGuildRoleData $ K.fromList [("hoist", toJSON v)] +modifyGuildRoleHoist v = ModifyGuildRoleData $ K.fromList [("hoist", Aeson.toJSON v)] modifyGuildRoleMentionable :: Maybe Bool -> ModifyGuildRoleData -modifyGuildRoleMentionable v = ModifyGuildRoleData $ K.fromList [("mentionable", toJSON v)] +modifyGuildRoleMentionable v = ModifyGuildRoleData $ K.fromList [("mentionable", Aeson.toJSON v)] data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData { id :: Snowflake Role , position :: Maybe Integer } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON ModifyGuildRolePositionsData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildRolePositionsData +instance CalamityToJSON' ModifyGuildRolePositionsData where + toPairs ModifyGuildRolePositionsData {..} = + [ "id" .= id + , "postition" .?= position + ] + data GuildRequest a where CreateGuild :: CreateGuildData -> GuildRequest Guild GetGuild :: HasID Guild g => g -> GuildRequest Guild @@ -351,7 +456,7 @@ ("limit" =:? limit <> "query" =: query) action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o) action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o) - action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ object ["nick" .= nick]) + action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ Aeson.object ["nick" Aeson..= nick]) action AddGuildMemberRole {} = putEmpty action RemoveGuildMemberRole {} = deleteWith action (RemoveGuildMember _ _) = deleteWith @@ -376,3 +481,12 @@ -- this is a bit of a hack -- TODO: add something to allow for contextual parsing modifyResponse _ = Prelude.id + +$(makeFieldLabelsNoPrefix ''CreateGuildData) +$(makeFieldLabelsNoPrefix ''ModifyGuildData) +$(makeFieldLabelsNoPrefix ''ChannelCreateData) +$(makeFieldLabelsNoPrefix ''ChannelPosition) +$(makeFieldLabelsNoPrefix ''ListMembersOptions) +$(makeFieldLabelsNoPrefix ''AddGuildMemberData) +$(makeFieldLabelsNoPrefix ''ModifyGuildRolePositionsData) +$(makeFieldLabelsNoPrefix ''CreateGuildBanData) diff --git a/Calamity/HTTP/Interaction.hs b/Calamity/HTTP/Interaction.hs --- a/Calamity/HTTP/Interaction.hs +++ b/Calamity/HTTP/Interaction.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Interaction endpoints module Calamity.HTTP.Interaction ( InteractionRequest (..), @@ -10,14 +12,13 @@ import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel.Component (Component, CustomID) import Calamity.Types.Model.Channel.Embed (Embed) import Calamity.Types.Model.Channel.Message (Message) import Calamity.Types.Model.Interaction import Calamity.Types.Snowflake -import Control.Lens hiding ((.=)) -import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Bits (shiftL, (.|.)) import Data.Default.Class import qualified Data.HashMap.Strict as H @@ -25,21 +26,25 @@ import Data.Monoid (First (First, getFirst)) import Data.Text (Text) import qualified Data.Text as T -import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime +import Optics import PyF -import TextShow -import qualified TextShow.Generic as TSG data InteractionCallback = InteractionCallback { type_ :: InteractionCallbackType - , data_ :: Maybe Value + , data_ :: Maybe Aeson.Value } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON InteractionCallback + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallback +instance CalamityToJSON' InteractionCallback where + toPairs InteractionCallback {..} = + [ "type" .= type_ + , "data" .?= data_ + ] + data InteractionCallbackMessageOptions = InteractionCallbackMessageOptions { tts :: Maybe Bool , content :: Maybe Text @@ -50,16 +55,26 @@ , components :: Maybe [Component] , attachments :: Maybe [CreateMessageAttachment] } - deriving (Show, Generic, Default) + deriving (Show) +instance Default InteractionCallbackMessageOptions where + def = InteractionCallbackMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + data CreateMessageAttachmentJson = CreateMessageAttachmentJson { id :: Int , filename :: Text , description :: Maybe Text } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson +instance CalamityToJSON' CreateMessageAttachmentJson where + toPairs CreateMessageAttachmentJson {..} = + [ "id" .= id + , "filename" .= filename + , "description" .?= description + ] + data CreateResponseMessageJson = CreateResponseMessageJson { tts :: Maybe Bool , content :: Maybe Text @@ -69,32 +84,60 @@ , components :: Maybe [Component] , attachments :: Maybe [CreateMessageAttachmentJson] } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateResponseMessageJson + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateResponseMessageJson +instance CalamityToJSON' CreateResponseMessageJson where + toPairs CreateResponseMessageJson {..} = + [ "tts" .?= tts + , "content" .?= content + , "embeds" .?= embeds + , "allowed_mentions" .?= allowedMentions + , "flags" .?= flags + , "components" .?= components + , "attachments" .?= attachments + ] + newtype InteractionCallbackAutocomplete = InteractionCallbackAutocomplete { choices :: [InteractionCallbackAutocompleteChoice] } - deriving stock (Show, Generic) - deriving (ToJSON) via CalamityJSON InteractionCallbackAutocomplete + deriving stock (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocomplete +instance CalamityToJSON' InteractionCallbackAutocomplete where + toPairs InteractionCallbackAutocomplete {..} = ["choices" .= choices] + data InteractionCallbackAutocompleteChoice = InteractionCallbackAutocompleteChoice { name :: Text , nameLocalizations :: H.HashMap Text Text , -- | Either text or numeric - value :: Value + value :: Aeson.Value } - deriving stock (Show, Generic) - deriving (ToJSON) via CalamityJSON InteractionCallbackAutocompleteChoice + deriving stock (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocompleteChoice +instance CalamityToJSON' InteractionCallbackAutocompleteChoice where + toPairs InteractionCallbackAutocompleteChoice {..} = + [ "name" .= name + , "name_localizations" .= nameLocalizations + , "value" .= value + ] + data InteractionCallbackModal = InteractionCallbackModal { customID :: CustomID , title :: Text , components :: [Component] } - deriving stock (Show, Generic) - deriving (ToJSON) via CalamityJSON InteractionCallbackModal + deriving stock (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackModal +instance CalamityToJSON' InteractionCallbackModal where + toPairs InteractionCallbackModal {..} = + [ "custom_id" .= customID + , "title" .= title + , "components" .= components + ] + data InteractionCallbackType = PongType | ChannelMessageWithSourceType @@ -103,11 +146,10 @@ | UpdateMessageType | ApplicationCommandAutocompleteResultType | ModalType - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric InteractionCallbackType + deriving (Show) -instance ToJSON InteractionCallbackType where - toEncoding ty = toEncoding @Int $ case ty of +instance Aeson.ToJSON InteractionCallbackType where + toJSON ty = Aeson.toJSON @Int $ case ty of PongType -> 1 ChannelMessageWithSourceType -> 4 DeferredChannelMessageWithSourceType -> 5 @@ -115,7 +157,20 @@ UpdateMessageType -> 7 ApplicationCommandAutocompleteResultType -> 8 ModalType -> 9 + toEncoding ty = Aeson.toEncoding @Int $ case ty of + PongType -> 1 + ChannelMessageWithSourceType -> 4 + DeferredChannelMessageWithSourceType -> 5 + DeferredUpdateMessageType -> 6 + UpdateMessageType -> 7 + ApplicationCommandAutocompleteResultType -> 8 + ModalType -> 9 +$(makeFieldLabelsNoPrefix ''InteractionCallbackMessageOptions) +$(makeFieldLabelsNoPrefix ''InteractionCallbackAutocomplete) +$(makeFieldLabelsNoPrefix ''InteractionCallbackAutocompleteChoice) +$(makeFieldLabelsNoPrefix ''InteractionCallbackModal) + data InteractionRequest a where CreateResponseMessage :: (HasID Interaction i) => @@ -257,7 +312,7 @@ let jsonBody = InteractionCallback { type_ = DeferredChannelMessageWithSourceType - , data_ = if ephemeral then Just . object $ [("flags", Number 64)] else Nothing + , data_ = if ephemeral then Just . Aeson.object $ [("flags", Aeson.Number 64)] else Nothing } in postWith' (ReqBodyJson jsonBody) action (CreateResponseDeferComponent _ _) = @@ -293,9 +348,9 @@ jsonBody = InteractionCallback { type_ = ChannelMessageWithSourceType - , data_ = Just . toJSON $ jsonData + , data_ = Just . Aeson.toJSON $ jsonData } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) postWith' body u o action (CreateResponseUpdate _ _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = @@ -323,22 +378,22 @@ jsonBody = InteractionCallback { type_ = UpdateMessageType - , data_ = Just . toJSON $ jsonData + , data_ = Just . Aeson.toJSON $ jsonData } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) postWith' body u o action (CreateResponseAutocomplete _ _ ao) = let jsonBody = InteractionCallback { type_ = ApplicationCommandAutocompleteResultType - , data_ = Just . toJSON $ ao + , data_ = Just . Aeson.toJSON $ ao } in postWith' (ReqBodyJson jsonBody) action (CreateResponseModal _ _ mo) = let jsonBody = InteractionCallback { type_ = ModalType - , data_ = Just . toJSON $ mo + , data_ = Just . Aeson.toJSON $ mo } in postWith' (ReqBodyJson jsonBody) action (GetOriginalInteractionResponse _ _) = getWith @@ -368,9 +423,9 @@ jsonBody = InteractionCallback { type_ = UpdateMessageType - , data_ = Just . toJSON $ jsonData + , data_ = Just . Aeson.toJSON $ jsonData } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) patchWith' body u o action (DeleteOriginalInteractionResponse _ _) = deleteWith action (CreateFollowupMessage _ _ cm) = \u o -> do @@ -396,7 +451,7 @@ , attachments = attachments , flags = flags } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonData) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonData) : files) postWith' body u o action GetFollowupMessage {} = getWith action (EditFollowupMessage _ _ _ cm) = \u o -> do @@ -422,6 +477,6 @@ , attachments = attachments , flags = flags } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonData) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonData) : files) patchWith' body u o action DeleteFollowupMessage {} = deleteWith diff --git a/Calamity/HTTP/Internal/Ratelimit.hs b/Calamity/HTTP/Internal/Ratelimit.hs --- a/Calamity/HTTP/Internal/Ratelimit.hs +++ b/Calamity/HTTP/Internal/Ratelimit.hs @@ -19,10 +19,9 @@ import qualified Control.Concurrent.Event as E import Control.Concurrent.STM import qualified Control.Exception.Safe as Ex -import Control.Lens import Control.Monad -import Data.Aeson -import Data.Aeson.Lens +import qualified Data.Aeson as Aeson +import Data.Aeson.Optics import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Maybe @@ -32,6 +31,8 @@ import Network.HTTP.Client (responseStatus) import Network.HTTP.Req import Network.HTTP.Types +import Optics +import Optics.Operators.Unsafe ((^?!)) import Polysemy (Sem, makeSem) import qualified Polysemy as P import PyF @@ -168,8 +169,8 @@ -- there are tokens remaining for us to use modifyTVar' (bucket ^. #state) - ( (#remaining -~ 1) - . (#ongoing +~ 1) + ( (#remaining %~ pred) + . (#ongoing %~ succ) ) pure GoNow else do @@ -240,31 +241,31 @@ computedEnd = flip addUTCTime now <$> resetAfter resetAfter :: Maybe NominalDiffTime - resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just . _Double + resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just % _Double end :: Maybe UTCTime end = posixSecondsToUTCTime . realToFrac - <$> responseHeader r "X-Ratelimit-Reset" ^? _Just . _Double + <$> responseHeader r "X-Ratelimit-Reset" ^? _Just % _Double buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString) buildBucketState now r = (,) <$> bs <*> bucketKey where - remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just . _Integral - limit = responseHeader r "X-RateLimit-Limit" ^? _Just . _Integral - resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just . _Double + remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just % _Integral + limit = responseHeader r "X-RateLimit-Limit" ^? _Just % _Integral + resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just % _Double resetTime = parseRateLimitHeader now r bs = BucketState resetTime <$> resetKey <*> remaining <*> limit <*> pure 0 bucketKey = responseHeader r "X-RateLimit-Bucket" -- | Parse the retry after field, returning when to retry -parseRetryAfter :: UTCTime -> Value -> UTCTime +parseRetryAfter :: UTCTime -> Aeson.Value -> UTCTime parseRetryAfter now r = addUTCTime retryAfter now where - retryAfter = realToFrac $ r ^?! key "retry_after" . _Double + retryAfter = realToFrac $ r ^?! key "retry_after" % _Double -isGlobal :: Value -> Bool -isGlobal r = r ^? key "global" . _Bool == Just True +isGlobal :: Aeson.Value -> Bool +isGlobal r = r ^? key "global" % _Bool == Just True -- Either (Either a a) b data ShouldRetry a b @@ -335,7 +336,7 @@ void . P.embed . atomically $ do case rl of KnownRatelimit bucket -> - modifyTVar' (bucket ^. #state) (#ongoing -~ 1) + modifyTVar' (bucket ^. #state) (#ongoing %~ succ) _ -> pure () case rlHeaders of Just (bs, bk) -> @@ -348,7 +349,7 @@ P.embed . atomically $ do case rl of KnownRatelimit bucket -> - modifyTVar' (bucket ^. #state) (#ongoing -~ 1) + modifyTVar' (bucket ^. #state) (#ongoing %~ succ) _ -> pure () void $ updateBucket rlstate (routeKey route) bk bs @@ -360,7 +361,7 @@ debug "Internal error (ratelimited but no headers), retrying" case rl of KnownRatelimit bucket -> - void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing -~ 1) + void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing %~ succ) _ -> pure () P.embed $ threadDelayUntil unlockWhen @@ -372,7 +373,7 @@ atomically $ do case rl of KnownRatelimit bucket -> - modifyTVar' (bucket ^. #state) (#ongoing -~ 1) + modifyTVar' (bucket ^. #state) (#ongoing %~ pred) _ -> pure () case bs of Just (bs', bk) -> @@ -403,7 +404,7 @@ KnownRatelimit bucket -> P.embed $ useBucketOnce bucket _ -> debug "unknown ratelimit" - pure $ RFail (HTTPError c $ decode v) + pure $ RFail (HTTPError c $ Aeson.decode v) doRequest :: P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) doRequest rlstate route action = diff --git a/Calamity/HTTP/Internal/Request.hs b/Calamity/HTTP/Internal/Request.hs --- a/Calamity/HTTP/Internal/Request.hs +++ b/Calamity/HTTP/Internal/Request.hs @@ -23,7 +23,6 @@ import Calamity.Types.LogEff (LogEff) import Calamity.Types.Token import Calamity.Types.TokenEff -import Control.Lens import Control.Monad import Data.Aeson hiding (Options) import Data.Aeson.Types (parseEither) @@ -32,6 +31,7 @@ import qualified Data.Text.Encoding as TS import DiPolysemy hiding (debug, error, info) import Network.HTTP.Req +import Optics import qualified Polysemy as P import qualified Polysemy.Error as P import Web.HttpApiData diff --git a/Calamity/HTTP/Internal/Route.hs b/Calamity/HTTP/Internal/Route.hs --- a/Calamity/HTTP/Internal/Route.hs +++ b/Calamity/HTTP/Internal/Route.hs @@ -1,50 +1,50 @@ --- | The route type --- Why I did this I don't know +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -module Calamity.HTTP.Internal.Route - ( mkRouteBuilder - , giveID - , giveParam - , buildRoute - , routeKey - , RouteKey - , RouteBuilder - , RouteRequirement - , Route(path) - , S(..) - , PS(..) - , ID(..) - , RouteFragmentable(..) ) where - -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Snowflake - -import Data.Hashable -import Data.Kind -import Data.Maybe ( fromJust ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Data.Typeable -import Data.Word -import Data.List ( foldl' ) - -import Network.HTTP.Req - -import GHC.Generics hiding ( S ) +{- | The route type + Why I did this I don't know +-} +module Calamity.HTTP.Internal.Route ( + mkRouteBuilder, + giveID, + giveParam, + buildRoute, + routeKey, + RouteKey, + RouteBuilder, + RouteRequirement, + Route (path), + S (..), + PS (..), + ID (..), + RouteFragmentable (..), +) where -import TextShow -import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake +import Data.Hashable +import Data.Kind +import Data.List (foldl') +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Data.Word +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Network.HTTP.Req +import Optics.TH +import qualified TextShow data RouteFragment - = S' Text - -- ^ Static string fragment - | PS' String - -- ^ Parameterised string fragment - | ID' TypeRep - -- ^ ID fragment - deriving ( Generic, Show, Eq ) + = -- | Static string fragment + S' Text + | -- | Parameterised string fragment + PS' String + | -- | ID fragment + ID' TypeRep + deriving (Generic, Show, Eq) -- | A static string fragment of a route newtype S = S Text @@ -61,7 +61,7 @@ = NotNeeded | Required | Satisfied - deriving ( Generic, Show, Eq ) + deriving (Show, Eq) data RequirementType = IDRequirement Type @@ -69,62 +69,62 @@ data RouteBuilder (reqstate :: [(RequirementType, RouteRequirement)]) = UnsafeMkRouteBuilder { route :: [RouteFragment] - , ids :: [(TypeRep, Word64)] + , ids :: [(TypeRep, Word64)] , params :: [(String, Text)] } mkRouteBuilder :: RouteBuilder '[] mkRouteBuilder = UnsafeMkRouteBuilder [] [] [] -giveID - :: forall t reqs - . Typeable t - => Snowflake t - -> RouteBuilder reqs - -> RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs) +giveID :: + forall t reqs. + Typeable t => + Snowflake t -> + RouteBuilder reqs -> + RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs) giveID (Snowflake id) (UnsafeMkRouteBuilder route ids params) = UnsafeMkRouteBuilder route ((typeRep $ Proxy @t, id) : ids) params -giveParam - :: forall (s :: Symbol) reqs - . KnownSymbol s - => Text - -> RouteBuilder reqs - -> RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs) +giveParam :: + forall (s :: Symbol) reqs. + KnownSymbol s => + Text -> + RouteBuilder reqs -> + RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs) giveParam value (UnsafeMkRouteBuilder route ids params) = UnsafeMkRouteBuilder route ids ((symbolVal $ Proxy @s, value) : params) type family (&&) (a :: Bool) (b :: Bool) :: Bool where 'True && 'True = 'True - _ && _ = 'False + _ && _ = 'False type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where Lookup k ('(k, v) ': xs) = 'Just v Lookup k ('(_, v) ': xs) = Lookup k xs - Lookup _ '[] = 'Nothing + Lookup _ '[] = 'Nothing type family IsElem (x :: k) (l :: [k]) :: Bool where - IsElem _ '[] = 'False - IsElem k (k : _) = 'True + IsElem _ '[] = 'False + IsElem k (k : _) = 'True IsElem k (_ : xs) = IsElem k xs type family EnsureFulfilled (reqs :: [(RequirementType, RouteRequirement)]) :: Constraint where EnsureFulfilled reqs = EnsureFulfilledInner reqs '[] 'True type family EnsureFulfilledInner (reqs :: [(RequirementType, RouteRequirement)]) (seen :: [RequirementType]) (ok :: Bool) :: Constraint where - EnsureFulfilledInner '[] _ 'True = () - EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok - EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok - EnsureFulfilledInner ('(k, 'Required) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok) + EnsureFulfilledInner '[] _ 'True = () + EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok + EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok + EnsureFulfilledInner ('(k, 'Required) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok) type family AddRequired k (reqs :: [(RequirementType, RouteRequirement)]) :: [(RequirementType, RouteRequirement)] where AddRequired k reqs = '(k, AddRequiredInner (Lookup k reqs)) ': reqs type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where - AddRequiredInner ('Just 'Required) = 'Required - AddRequiredInner ('Just 'Satisfied) = 'Satisfied - AddRequiredInner ('Just 'NotNeeded) = 'Required - AddRequiredInner 'Nothing = 'Required + AddRequiredInner ( 'Just 'Required) = 'Required + AddRequiredInner ( 'Just 'Satisfied) = 'Satisfied + AddRequiredInner ( 'Just 'NotNeeded) = 'Required + AddRequiredInner 'Nothing = 'Required class Typeable a => RouteFragmentable a reqs where type ConsRes a reqs @@ -138,26 +138,26 @@ UnsafeMkRouteBuilder (r <> [S' t]) ids params instance Typeable a => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where - type ConsRes (ID a) reqs = RouteBuilder (AddRequired ('IDRequirement a) reqs) + type ConsRes (ID a) reqs = RouteBuilder (AddRequired ( 'IDRequirement a) reqs) (UnsafeMkRouteBuilder r ids params) // ID = UnsafeMkRouteBuilder (r <> [ID' $ typeRep $ Proxy @a]) ids params instance KnownSymbol s => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where - type ConsRes (PS s) reqs = RouteBuilder (AddRequired ('PSRequirement s) reqs) + type ConsRes (PS s) reqs = RouteBuilder (AddRequired ( 'PSRequirement s) reqs) (UnsafeMkRouteBuilder r ids params) // PS = UnsafeMkRouteBuilder (r <> [PS' $ symbolVal $ Proxy @s]) ids params - infixl 5 // data Route = Route - { path :: Url 'Https - , key :: Text + { path :: Url 'Https + , key :: Text , channelID :: Maybe (Snowflake Channel) - , guildID :: Maybe (Snowflake Guild) - } deriving (Generic, Show) + , guildID :: Maybe (Snowflake Guild) + } + deriving (Show) type RouteKey = (Text, Maybe (Snowflake Channel), Maybe (Snowflake Guild)) @@ -167,21 +167,24 @@ baseURL :: Url 'Https baseURL = https "discord.com" /: "api" /: "v10" -buildRoute - :: forall (reqs :: [(RequirementType, RouteRequirement)]) - . EnsureFulfilled reqs - => RouteBuilder reqs - -> Route -buildRoute (UnsafeMkRouteBuilder route ids params) = Route - (foldl' (/:) baseURL $ map goR route) - (T.concat (map goIdent route)) - (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids) - (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids) - where - goR (S' t) = t - goR (PS' t) = fromJust $ lookup t params - goR (ID' t) = showt . fromJust $ lookup t ids +buildRoute :: + forall (reqs :: [(RequirementType, RouteRequirement)]). + EnsureFulfilled reqs => + RouteBuilder reqs -> + Route +buildRoute (UnsafeMkRouteBuilder route ids params) = + Route + (foldl' (/:) baseURL $ map goR route) + (T.concat (map goIdent route)) + (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids) + (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids) + where + goR (S' t) = t + goR (PS' t) = fromJust $ lookup t params + goR (ID' t) = TextShow.showt . fromJust $ lookup t ids - goIdent (S' t) = t - goIdent (PS' s) = T.pack s - goIdent (ID' t) = showt t + goIdent (S' t) = t + goIdent (PS' s) = T.pack s + goIdent (ID' t) = TextShow.showt t + +$(makeFieldLabelsNoPrefix ''Route) diff --git a/Calamity/HTTP/Internal/Types.hs b/Calamity/HTTP/Internal/Types.hs --- a/Calamity/HTTP/Internal/Types.hs +++ b/Calamity/HTTP/Internal/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Types for the http lib module Calamity.HTTP.Internal.Types ( RestError(..) @@ -8,8 +10,7 @@ , GatewayResponse , BotGatewayResponse ) where -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings +import Calamity.HTTP.Internal.Route import Control.Concurrent.Event ( Event ) import Control.Concurrent.STM.TVar ( TVar ) import Data.Time @@ -17,8 +18,9 @@ import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B import Data.Text as T -import GHC.Generics import qualified StmContainers.Map as SC +import qualified Data.Aeson as Aeson +import Optics.TH data RestError -- | An error response from discord @@ -28,7 +30,7 @@ } -- | Something failed while making the request (after retrying a few times) | InternalClientError T.Text - deriving ( Show, Generic ) + deriving ( Show) data BucketState = BucketState { resetTime :: Maybe UTCTime @@ -42,19 +44,17 @@ , ongoing :: Int -- ^ How many ongoing requests } - deriving ( Generic, Show ) + deriving ( Show ) newtype Bucket = Bucket { state :: TVar BucketState } - deriving ( Generic ) data RateLimitState = RateLimitState { bucketKeys :: SC.Map RouteKey B.ByteString , buckets :: SC.Map B.ByteString Bucket , globalLock :: Event } - deriving ( Generic ) data DiscordResponseType = Good @@ -76,12 +76,26 @@ newtype GatewayResponse = GatewayResponse { url :: T.Text } - deriving ( Generic, Show ) - deriving ( FromJSON ) via CalamityJSON GatewayResponse + deriving stock ( Show ) +instance Aeson.FromJSON GatewayResponse where + parseJSON = Aeson.withObject "GatewayResponse" $ \v -> + GatewayResponse <$> v .: "url" + data BotGatewayResponse = BotGatewayResponse { url :: T.Text , shards :: Int } - deriving ( Generic, Show ) - deriving ( FromJSON ) via CalamityJSON BotGatewayResponse + deriving ( Show ) + +instance Aeson.FromJSON BotGatewayResponse where + parseJSON = Aeson.withObject "BotGatewayResponse" $ \v -> + BotGatewayResponse + <$> v .: "url" + <*> v .: "shards" + +$(makeFieldLabelsNoPrefix ''Bucket) +$(makeFieldLabelsNoPrefix ''BucketState) +$(makeFieldLabelsNoPrefix ''RateLimitState) +$(makeFieldLabelsNoPrefix ''GatewayResponse) +$(makeFieldLabelsNoPrefix ''BotGatewayResponse) diff --git a/Calamity/HTTP/Invite.hs b/Calamity/HTTP/Invite.hs --- a/Calamity/HTTP/Invite.hs +++ b/Calamity/HTTP/Invite.hs @@ -4,11 +4,8 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.Types.Model.Guild - -import Control.Lens hiding ((.=)) - +import Data.Function ((&)) import Data.Text (Text) - import Network.HTTP.Req data InviteRequest a where diff --git a/Calamity/HTTP/MiscRoutes.hs b/Calamity/HTTP/MiscRoutes.hs --- a/Calamity/HTTP/MiscRoutes.hs +++ b/Calamity/HTTP/MiscRoutes.hs @@ -4,8 +4,7 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route import Calamity.HTTP.Internal.Types - -import Data.Function +import Data.Function ((&)) data MiscRequest a where GetGateway :: MiscRequest GatewayResponse diff --git a/Calamity/HTTP/Reason.hs b/Calamity/HTTP/Reason.hs --- a/Calamity/HTTP/Reason.hs +++ b/Calamity/HTTP/Reason.hs @@ -5,16 +5,12 @@ ) where import Calamity.HTTP.Internal.Request - import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) - -import GHC.Generics - import Network.HTTP.Req data Reason a = Reason a Text - deriving (Show, Eq, Generic) + deriving (Show, Eq) -- | Attach a reason to a request reason :: Request a => Text -> a -> Reason a diff --git a/Calamity/HTTP/User.hs b/Calamity/HTTP/User.hs --- a/Calamity/HTTP/User.hs +++ b/Calamity/HTTP/User.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | User endpoints module Calamity.HTTP.User ( UserRequest (..), @@ -7,20 +9,16 @@ import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake - -import Control.Lens hiding ((.=)) - -import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Default.Class +import Data.Function ((&)) import Data.Text (Text) - -import GHC.Generics - +import Optics.TH import Network.HTTP.Req data ModifyUserData = ModifyUserData @@ -28,16 +26,28 @@ , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data avatar :: Maybe Text } - deriving (Show, Generic, Default) - deriving (ToJSON) via CalamityJSON ModifyUserData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyUserData +instance CalamityToJSON' ModifyUserData where + toPairs ModifyUserData {..} = + [ "username" .?= username + , "avatar" .?= avatar + ] + +instance Default ModifyUserData where + def = ModifyUserData Nothing Nothing + data GetCurrentUserGuildsOptions = GetCurrentUserGuildsOptions { before :: Maybe (Snowflake Guild) , after :: Maybe (Snowflake Guild) , limit :: Maybe Integer } - deriving (Show, Generic, Default) + deriving (Show) +instance Default GetCurrentUserGuildsOptions where + def = GetCurrentUserGuildsOptions Nothing Nothing Nothing + data UserRequest a where GetCurrentUser :: UserRequest User GetUser :: HasID User u => u -> UserRequest User @@ -76,10 +86,13 @@ action GetCurrentUser = getWith action (GetUser _) = getWith action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o - action (GetCurrentUserGuilds GetCurrentUserGuildsOptions{before, after, limit}) = + action (GetCurrentUserGuilds GetCurrentUserGuildsOptions {before, after, limit}) = getWithP ( "before" =:? (fromSnowflake <$> before) <> "after" =:? (fromSnowflake <$> after) <> "limit" =:? limit ) action (LeaveGuild _) = deleteWith - action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (object ["recipient_id" .= uid]) + action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (Aeson.object ["recipient_id" Aeson..= uid]) + +$(makeFieldLabelsNoPrefix ''ModifyUserData) +$(makeFieldLabelsNoPrefix ''GetCurrentUserGuildsOptions) diff --git a/Calamity/HTTP/Webhook.hs b/Calamity/HTTP/Webhook.hs --- a/Calamity/HTTP/Webhook.hs +++ b/Calamity/HTTP/Webhook.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Webhook endpoints module Calamity.HTTP.Webhook ( WebhookRequest (..), @@ -9,19 +11,18 @@ import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) import Calamity.HTTP.Internal.Request import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Snowflake -import Control.Lens hiding ((.=)) -import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Default.Class import Data.Text (Text) import qualified Data.Text as T -import GHC.Generics import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime +import Optics import PyF data CreateWebhookData = CreateWebhookData @@ -29,18 +30,37 @@ , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data avatar :: Maybe Text } - deriving (Show, Generic, Default) - deriving (ToJSON) via CalamityJSON CreateWebhookData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateWebhookData +instance CalamityToJSON' CreateWebhookData where + toPairs CreateWebhookData {..} = + [ "username" .?= username + , "avatar" .?= avatar + ] + +instance Default CreateWebhookData where + def = CreateWebhookData Nothing Nothing + data ModifyWebhookData = ModifyWebhookData { username :: Maybe Text , -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data avatar :: Maybe Text , channelID :: Maybe (Snowflake Channel) } - deriving (Show, Generic, Default) - deriving (ToJSON) via CalamityJSON ModifyWebhookData + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyWebhookData +instance CalamityToJSON' ModifyWebhookData where + toPairs ModifyWebhookData {..} = + [ "username" .?= username + , "avatar" .?= avatar + , "channel_id" .?= channelID + ] + +instance Default ModifyWebhookData where + def = ModifyWebhookData Nothing Nothing Nothing + data ExecuteWebhookOptions = ExecuteWebhookOptions { wait :: Maybe Bool , content :: Maybe Text @@ -52,16 +72,26 @@ , tts :: Maybe Bool , components :: [Component] } - deriving (Show, Generic, Default) + deriving (Show) +instance Default ExecuteWebhookOptions where + def = ExecuteWebhookOptions Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing [] + data CreateMessageAttachmentJson = CreateMessageAttachmentJson { id :: Int , filename :: Text , description :: Maybe Text } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON CreateMessageAttachmentJson + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson +instance CalamityToJSON' CreateMessageAttachmentJson where + toPairs CreateMessageAttachmentJson {..} = + [ "id" .= id + , "filename" .= filename + , "description" .?= description + ] + data ExecuteWebhookJson = ExecuteWebhookJson { content :: Maybe Text , embeds :: Maybe [Embed] @@ -72,9 +102,24 @@ , allowedMentions :: Maybe AllowedMentions , components :: [Component] } - deriving (Show, Generic) - deriving (ToJSON) via CalamityJSON ExecuteWebhookJson + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ExecuteWebhookJson +instance CalamityToJSON' ExecuteWebhookJson where + toPairs ExecuteWebhookJson {..} = + [ "content" .?= content + , "embeds" .?= embeds + , "avatar_url" .?= avatarUrl + , "tts" .?= tts + , "attachments" .= attachments + , "allowed_mentions" .?= allowedMentions + , "components" .= components + ] + +$(makeFieldLabelsNoPrefix ''CreateWebhookData) +$(makeFieldLabelsNoPrefix ''ModifyWebhookData) +$(makeFieldLabelsNoPrefix ''ExecuteWebhookOptions) + data WebhookRequest a where CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook] @@ -157,5 +202,5 @@ , components = wh ^. #components , attachments = attachments } - body <- reqBodyMultipart (partLBS "payload_json" (encode jsonBody) : files) + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) postWithP' body ("wait" =:? (wh ^. #wait)) u o diff --git a/Calamity/Interactions/Eff.hs b/Calamity/Interactions/Eff.hs --- a/Calamity/Interactions/Eff.hs +++ b/Calamity/Interactions/Eff.hs @@ -14,7 +14,7 @@ import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake import Control.Applicative ((<|>)) -import Control.Lens ((^.), (^?), _Just) +import Optics ((^.), (^?), _Just, (%)) import Data.Maybe (fromJust) import Polysemy import qualified Polysemy as P @@ -36,7 +36,7 @@ getInteractionUser :: P.Member InteractionEff r => P.Sem r (Snowflake User) getInteractionUser = do int <- getInteraction - let uid = int ^? #user . _Just . #id - mid = int ^? #member . _Just . #id + let uid = int ^? #user % _Just % #id + mid = int ^? #member % _Just % #id pure . fromJust $ uid <|> mid diff --git a/Calamity/Interactions/Utils.hs b/Calamity/Interactions/Utils.hs --- a/Calamity/Interactions/Utils.hs +++ b/Calamity/Interactions/Utils.hs @@ -20,7 +20,7 @@ import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake (Snowflake) import Calamity.Types.Tellable -import Control.Lens ((^.)) +import Optics import qualified Data.HashMap.Strict as H import Data.Text (Text) import qualified Polysemy as P diff --git a/Calamity/Interactions/View.hs b/Calamity/Interactions/View.hs --- a/Calamity/Interactions/View.hs +++ b/Calamity/Interactions/View.hs @@ -25,7 +25,6 @@ import Calamity.HTTP.Internal.Ratelimit (RatelimitEff) import Calamity.HTTP.Internal.Request (invoke) import Calamity.Interactions.Eff (InteractionEff (..)) -import Calamity.Internal.AesonThings import Calamity.Metrics.Eff (MetricEff) import Calamity.Types.LogEff (LogEff) import Calamity.Types.Model.Channel.Component (CustomID) @@ -34,19 +33,19 @@ import Calamity.Types.Model.Interaction import Calamity.Types.TokenEff (TokenEff) import qualified Control.Concurrent.STM as STM -import Control.Lens ((.~), (?~), (^.), (^..), _1, _2, _3, _Just) +import Optics import Control.Monad (guard, void) -import qualified Data.Aeson -import Data.Aeson.Lens (AsValue (_Array), key) +import qualified Data.Aeson as Aeson import qualified Data.List import qualified Data.Set as S import Data.Text (Text) -import GHC.Generics (Generic) import qualified GHC.TypeLits as E import qualified Polysemy as P import qualified Polysemy.Resource as P import qualified Polysemy.State as P import System.Random +import Data.Aeson ((.:?), (.:)) +import Data.Aeson.Optics data ViewComponent a = ViewComponent { component :: C.Component @@ -213,12 +212,12 @@ select' opts f = SingView $ \g -> let (cid, g') = uniform g comp = f $ C.select opts cid - finalValues = S.fromList $ comp ^.. #options . traverse . #value + finalValues = S.fromList $ comp ^.. #options % traversed % #value parse int = extractOkFromMaybe $ do customID <- extractCustomID int guard $ customID == cid guardComponentType int C.SelectType - values <- int ^. #data_ . _Just . #values + values <- int ^? #data_ % _Just % #values % _Just let values' = S.fromList values guard $ S.isSubsetOf values' finalValues pure values @@ -228,20 +227,27 @@ { value :: Maybe Text , customID :: CustomID } - deriving (Show, Generic) - deriving (Data.Aeson.FromJSON) via CalamityJSON TextInputDecoded + deriving (Show) +$(makeFieldLabelsNoPrefix ''TextInputDecoded) + +instance Aeson.FromJSON TextInputDecoded where + parseJSON = Aeson.withObject "TextInputDecoded" $ \v -> + TextInputDecoded + <$> v .:? "value" + <*> v .: "custom_id" + parseTextInput :: CustomID -> Interaction -> ExtractResult (Maybe Text) parseTextInput cid int = extractOkFromMaybe $ do - components <- int ^. #data_ . _Just . #components + components <- int ^? #data_ % _Just % #components -- currently, each text input is a singleton actionrow containing a single textinput component - let textInputs = components ^.. traverse . key "components" . _Array . traverse - inputs' :: Data.Aeson.Result [TextInputDecoded] = traverse Data.Aeson.fromJSON textInputs + let textInputs = components ^.. traversed % traversed % key "components" % _Array % traversed + inputs' :: Aeson.Result [TextInputDecoded] = traverse Aeson.fromJSON textInputs inputs <- case inputs' of - Data.Aeson.Success x -> pure x - Data.Aeson.Error _ -> Nothing + Aeson.Success x -> pure x + Aeson.Error _ -> Nothing thisValue <- Data.List.find ((== cid) . (^. #customID)) inputs diff --git a/Calamity/Internal/AesonThings.hs b/Calamity/Internal/AesonThings.hs deleted file mode 100644 --- a/Calamity/Internal/AesonThings.hs +++ /dev/null @@ -1,159 +0,0 @@ -module Calamity.Internal.AesonThings ( - WithSpecialCases (..), - IfNoneThen, - ExtractFieldFrom, - ExtractFieldInto, - ExtractFields, - ExtractArrayField, - DefaultToEmptyArray, - DefaultToZero, - DefaultToFalse, - DefaultToTrue, - CalamityJSON (..), - CalamityJSONKeepNothing (..), - jsonOptions, - jsonOptionsKeepNothing, -) where - -import Control.Lens - -import Data.Aeson -import Data.Aeson.Lens -import Data.Aeson.Types (Parser) -import Data.Kind -import Data.Reflection (Reifies (..)) -import Data.String (IsString (fromString)) -import Data.Typeable - -import Control.Monad ((>=>)) -import GHC.Generics -import GHC.TypeLits (KnownSymbol, symbolVal) - -textSymbolVal :: forall n s. (KnownSymbol n, IsString s) => s -textSymbolVal = fromString $ symbolVal @n Proxy - -data IfNoneThen label def -data ExtractFieldInto label field target -type ExtractFieldFrom label field = ExtractFieldInto label field label -data ExtractFields label fields -data ExtractArrayField label field -data MapFieldWith field ty - -class PerformAction action where - runAction :: Proxy action -> Object -> Parser Object - -instance (Reifies d Value, KnownSymbol label) => PerformAction (IfNoneThen label d) where - runAction _ o = do - v <- o .:? textSymbolVal @label .!= reflect @d Proxy - pure $ o & at (textSymbolVal @label) ?~ v - -instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where - runAction _ o = - let v :: Maybe Value = o ^? ix (textSymbolVal @label) . _Object . ix (textSymbolVal @field) - in pure $ o & at (textSymbolVal @target) .~ v - -instance PerformAction (ExtractFields label '[]) where - runAction _ = pure - -instance - ( KnownSymbol field - , PerformAction (ExtractFieldInto label field field) - , PerformAction (ExtractFields label fields) - ) => - PerformAction (ExtractFields label (field : fields)) - where - runAction _ = runAction (Proxy @(ExtractFieldInto label field field)) >=> runAction (Proxy @(ExtractFields label fields)) - -instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where - runAction _ o = do - a :: Maybe Array <- o .:? textSymbolVal @label - case a of - Just a' -> do - a'' <- Array <$> traverse (withObject "extracting field" (.: textSymbolVal @field)) a' - pure $ o & at (textSymbolVal @label) ?~ a'' - Nothing -> pure o - -instance (KnownSymbol field, Reifies ty (Value -> Value)) => PerformAction (MapFieldWith field ty) where - runAction _ o = pure (o & ix (textSymbolVal @field) %~ reflect @ty Proxy) - -newtype WithSpecialCases (rules :: [Type]) a = WithSpecialCases a - -class RunSpecialCase a where - runSpecialCases :: Proxy a -> Object -> Parser Object - -instance RunSpecialCase '[] where - runSpecialCases _ = pure - -instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where - runSpecialCases _ o = do - o' <- runSpecialCases (Proxy @xs) o - runAction (Proxy @action) o' - -instance - (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a)) => - FromJSON (WithSpecialCases rules a) - where - parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do - o' <- runSpecialCases (Proxy @rules) o - WithSpecialCases <$> genericParseJSON jsonOptions (Object o') - -data DefaultToEmptyArray - -instance Reifies DefaultToEmptyArray Value where - reflect _ = Array mempty - -data DefaultToZero - -instance Reifies DefaultToZero Value where - reflect _ = Number 0 - -data DefaultToFalse - -instance Reifies DefaultToFalse Value where - reflect _ = Bool False - -data DefaultToTrue - -instance Reifies DefaultToTrue Value where - reflect _ = Bool True - -newtype CalamityJSON a = CalamityJSON - { unCalamityJSON :: a - } - -instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSON a) where - toJSON = genericToJSON jsonOptions . unCalamityJSON - - toEncoding = genericToEncoding jsonOptions . unCalamityJSON - -instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSON a) where - parseJSON = fmap CalamityJSON . genericParseJSON jsonOptions - --- | version that keeps Nothing fields -newtype CalamityJSONKeepNothing a = CalamityJSONKeepNothing - { unCalamityJSONKeepNothing :: a - } - -instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSONKeepNothing a) where - toJSON = genericToJSON jsonOptionsKeepNothing . unCalamityJSONKeepNothing - - toEncoding = genericToEncoding jsonOptionsKeepNothing . unCalamityJSONKeepNothing - -instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSONKeepNothing a) where - parseJSON = fmap CalamityJSONKeepNothing . genericParseJSON jsonOptionsKeepNothing - -jsonOptions :: Options -jsonOptions = - defaultOptions - { sumEncoding = UntaggedValue - , fieldLabelModifier = camelTo2 '_' . filter (/= '_') - , omitNothingFields = True - } - -jsonOptionsKeepNothing :: Options -jsonOptionsKeepNothing = - defaultOptions - { sumEncoding = UntaggedValue - , fieldLabelModifier = camelTo2 '_' . filter (/= '_') - , omitNothingFields = False - } diff --git a/Calamity/Internal/BoundedStore.hs b/Calamity/Internal/BoundedStore.hs --- a/Calamity/Internal/BoundedStore.hs +++ b/Calamity/Internal/BoundedStore.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | A thing for storing the last N things with IDs module Calamity.Internal.BoundedStore ( BoundedStore, @@ -7,17 +9,16 @@ dropItem, ) where -import Calamity.Internal.Utils -import Calamity.Types.Snowflake -import Control.Lens -import Control.Monad.State.Lazy -import Data.Default.Class -import Data.Generics.Labels () +import Calamity.Internal.Utils ( unlessM, whenM ) +import Calamity.Types.Snowflake ( HasID(getID), Snowflake, HasID' ) +import Control.Monad.State.Lazy ( when, execState ) +import Data.Default.Class ( Default(..) ) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H import Deque.Lazy (Deque) import qualified Deque.Lazy as DQ -import GHC.Generics +import Optics +import Optics.State.Operators ((%=), (.=)) data BoundedStore a = BoundedStore { itemQueue :: Deque (Snowflake a) @@ -25,8 +26,10 @@ , limit :: Int , size :: Int } - deriving (Show, Generic) + deriving (Show) +$(makeFieldLabelsNoPrefix ''BoundedStore) + instance Foldable BoundedStore where foldr f i = foldr f i . H.elems . items @@ -43,19 +46,18 @@ instance HasID' a => Ixed (BoundedStore a) instance HasID' a => At (BoundedStore a) where - at k f m = - f mv <&> \case - Nothing -> maybe m (const (dropItem k m)) mv - Just v -> addItem v m - where - mv = getItem k m + at k = lensVL $ \f m -> + let mv = getItem k m + in f mv <&> \case + Nothing -> maybe m (const (dropItem k m)) mv + Just v -> addItem v m {-# INLINE at #-} addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a addItem m = execState $ do unlessM (H.member (getID m) <$> use #items) $ do #itemQueue %= DQ.cons (getID m) - #size += 1 + #size %= succ size <- use #size limit <- use #limit @@ -65,7 +67,7 @@ let Just (rid, q') = DQ.unsnoc q #itemQueue .= q' #items %= sans rid - #size -= 1 + #size %= pred #items %= H.insert (getID m) m {-# INLINE addItem #-} @@ -77,7 +79,7 @@ dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a dropItem id = execState $ do whenM (H.member id <$> use #items) $ do - #size -= 1 + #size %= pred #itemQueue %= DQ.filter (/= id) #items %= H.delete id diff --git a/Calamity/Internal/IntColour.hs b/Calamity/Internal/IntColour.hs --- a/Calamity/Internal/IntColour.hs +++ b/Calamity/Internal/IntColour.hs @@ -1,8 +1,8 @@ -- | An internal newtype for parsing colours module Calamity.Internal.IntColour ( - IntColour (..), - colourToWord64, - colourFromWord64, + IntColour (..), + colourToWord64, + colourFromWord64, ) where import Data.Aeson @@ -10,29 +10,29 @@ import Data.Colour import Data.Colour.SRGB (RGB (RGB), sRGB24, toSRGB24) import Data.Word (Word64) -import GHC.Generics import TextShow -newtype IntColour = IntColour (Colour Double) - deriving stock (Generic) - deriving (Show) via Colour Double - deriving (TextShow) via FromStringShow (Colour Double) +newtype IntColour = IntColour + { fromIntColour :: Colour Double + } + deriving (Show) via Colour Double + deriving (TextShow) via FromStringShow (Colour Double) colourToWord64 :: IntColour -> Word64 colourToWord64 (IntColour c) = - let RGB r g b = toSRGB24 c - i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b - in i + let RGB r g b = toSRGB24 c + i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b + in i colourFromWord64 :: Word64 -> IntColour colourFromWord64 i = - let r = (i `shiftR` 16) .&. 0xff - g = (i `shiftR` 8) .&. 0xff - b = i .&. 0xff - in IntColour $ sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b) + let r = (i `shiftR` 16) .&. 0xff + g = (i `shiftR` 8) .&. 0xff + b = i .&. 0xff + in IntColour $ sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b) instance ToJSON IntColour where - toJSON = toJSON . colourToWord64 + toJSON = toJSON . colourToWord64 instance FromJSON IntColour where - parseJSON v = colourFromWord64 <$> parseJSON v + parseJSON v = colourFromWord64 <$> parseJSON v diff --git a/Calamity/Internal/OverriddenVia.hs b/Calamity/Internal/OverriddenVia.hs deleted file mode 100644 --- a/Calamity/Internal/OverriddenVia.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | Internal newtype that we can safely define orphans on -module Calamity.Internal.OverriddenVia ( - OverriddenVia (..), -) where - -import Calamity.Internal.ShapeCoerce -import Data.Aeson.Types -import Data.Default.Class -import TextShow - -{- | @a@: The type that is to be wrapped - @b@: The type to convert to and use the instance of --} -newtype OverriddenVia a b = OverriddenVia {unOverrideVia :: a} - -instance (ShapeCoerce b a, Default b) => Default (OverriddenVia a b) where - def = OverriddenVia $ shapeCoerce @b @a $ def - -instance (ShapeCoerce a b, Show b) => Show (OverriddenVia a b) where - showsPrec d (OverriddenVia x) = showsPrec d $ shapeCoerce @a @b x - show (OverriddenVia x) = show $ shapeCoerce @a @b x - showList xs = showList $ map (shapeCoerce @a @b . unOverrideVia) xs - -instance (ShapeCoerce b a, FromJSON b) => FromJSON (OverriddenVia a b) where - parseJSON v = OverriddenVia . shapeCoerce @b @a <$> parseJSON v - parseJSONList v = map (OverriddenVia . shapeCoerce @b @a) <$> parseJSONList v - -instance (ShapeCoerce a b, ToJSON b) => ToJSON (OverriddenVia a b) where - toJSON = toJSON . shapeCoerce @a @b . unOverrideVia - toEncoding = toEncoding . shapeCoerce @a @b . unOverrideVia - - toJSONList = toJSONList . map (shapeCoerce @a @b . unOverrideVia) - toEncodingList = toEncodingList . map (shapeCoerce @a @b . unOverrideVia) - -instance (ShapeCoerce a b, TextShow b) => TextShow (OverriddenVia a b) where - showb = showb . shapeCoerce @a @b . unOverrideVia diff --git a/Calamity/Internal/ShapeCoerce.hs b/Calamity/Internal/ShapeCoerce.hs deleted file mode 100644 --- a/Calamity/Internal/ShapeCoerce.hs +++ /dev/null @@ -1,37 +0,0 @@ -{- | Something to coerce between two records with the same field names and - compatible field types --} -module Calamity.Internal.ShapeCoerce ( - shapeCoerce, - ShapeCoerce, - GShapeCoerce (..), -) where - -import Data.Coerce (Coercible, coerce) -import GHC.Generics - -type ShapeCoerce a b = (Generic a, Generic b, GShapeCoerce (Rep a) (Rep b)) - -shapeCoerce :: (Generic a, Generic b, GShapeCoerce (Rep a) (Rep b)) => a -> b -shapeCoerce = to . gshapeCoerce . from - -class GShapeCoerce f g where - gshapeCoerce :: f a -> g b - -instance (GShapeCoerce fa ga, GShapeCoerce fb gb) => GShapeCoerce (fa :*: fb) (ga :*: gb) where - gshapeCoerce (la :*: lb) = gshapeCoerce la :*: gshapeCoerce lb - -instance GShapeCoerce f g => GShapeCoerce (M1 D da f) (M1 D db g) where - gshapeCoerce (M1 a) = M1 (gshapeCoerce a) - -instance GShapeCoerce f g => GShapeCoerce (M1 C da f) (M1 C db g) where - gshapeCoerce (M1 a) = M1 (gshapeCoerce a) - -instance GShapeCoerce f g => GShapeCoerce (S1 ( 'MetaSel ( 'Just name) fsu fss fl) f) (S1 ( 'MetaSel ( 'Just name') gsu gss gl) g) where - gshapeCoerce (M1 a) = M1 (gshapeCoerce a) - -instance GShapeCoerce f g => GShapeCoerce (S1 ( 'MetaSel 'Nothing fsu fss fl) f) (S1 ( 'MetaSel 'Nothing gsu gss gl) g) where - gshapeCoerce (M1 a) = M1 (gshapeCoerce a) - -instance Coercible a b => GShapeCoerce (Rec0 a) (Rec0 b) where - gshapeCoerce (K1 a) = K1 $ coerce a diff --git a/Calamity/Internal/SnowflakeMap.hs b/Calamity/Internal/SnowflakeMap.hs --- a/Calamity/Internal/SnowflakeMap.hs +++ b/Calamity/Internal/SnowflakeMap.hs @@ -3,10 +3,6 @@ import Calamity.Internal.Utils () import Calamity.Types.Snowflake -import Control.DeepSeq -import Control.Lens.At -import Control.Lens.Iso -import Control.Lens.Wrapped import Data.Aeson (FromJSON (..), ToJSON (..), withArray) import Data.Data import qualified Data.Foldable as F @@ -14,17 +10,17 @@ import qualified Data.HashMap.Strict as SH import Data.Hashable import GHC.Exts (IsList) -import GHC.Generics +import Optics import TextShow import Unsafe.Coerce newtype SnowflakeMap a = SnowflakeMap { unSnowflakeMap :: HashMap (Snowflake a) a } - deriving stock (Generic, Eq, Data, Ord, Show) + deriving stock (Eq, Data, Ord, Show) deriving (TextShow) via FromStringShow (SnowflakeMap a) deriving newtype (IsList, Semigroup, Monoid) - deriving newtype (NFData, Hashable) + deriving newtype (Hashable) -- instance At (SnowflakeMap a) where -- at k f m = at (unSnowflakeMap k) f m @@ -38,30 +34,30 @@ instance Traversable SnowflakeMap where traverse f = fmap (SnowflakeMap . coerceSnowflakeMap) . traverse f . unSnowflakeMap --- deriving instance NFData a => NFData (SnowflakeMap a) - --- deriving instance Hashable a => Hashable (SnowflakeMap a) - -instance Wrapped (SnowflakeMap a) where - type Unwrapped (SnowflakeMap a) = HashMap (Snowflake a) a - - _Wrapped' = iso unSnowflakeMap SnowflakeMap - type instance Index (SnowflakeMap a) = Snowflake a type instance IxValue (SnowflakeMap a) = a -instance SnowflakeMap a ~ t => Rewrapped (SnowflakeMap b) a +_SnowflakeMap :: + ( Iso + (SnowflakeMap a) + (SnowflakeMap a1) + (HashMap (Snowflake a) a) + (HashMap (Snowflake a1) a1) + ) +_SnowflakeMap = iso unSnowflakeMap SnowflakeMap instance Ixed (SnowflakeMap a) where - ix i = _Wrapped . ix i + ix i = _SnowflakeMap % ix i + {-# INLINE ix #-} instance At (SnowflakeMap a) where - at i = _Wrapped . at i + at i = _SnowflakeMap % at i + {-# INLINE at #-} -over :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b -over f = SnowflakeMap . f . unSnowflakeMap -{-# INLINEABLE over #-} +overSM :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b +overSM f = SnowflakeMap . f . unSnowflakeMap +{-# INLINEABLE overSM #-} -- SAFETY: 'Snowflake' always uses the underlying hash function (Word64) coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v @@ -103,27 +99,27 @@ infixl 9 ! insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a -insert v = over $ SH.insert (getID v) v +insert v = overSM $ SH.insert (getID v) v {-# INLINEABLE insert #-} insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a -insertWith f v = over $ SH.insertWith f (getID v) v +insertWith f v = overSM $ SH.insertWith f (getID v) v {-# INLINEABLE insertWith #-} delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a -delete k = over $ SH.delete k +delete k = overSM $ SH.delete k {-# INLINEABLE delete #-} adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -adjust f k = over $ SH.adjust f k +adjust f k = overSM $ SH.adjust f k {-# INLINEABLE adjust #-} update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -update f k = over $ SH.update f k +update f k = overSM $ SH.update f k {-# INLINEABLE update #-} alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -alter f k = over $ SH.alter f k +alter f k = overSM $ SH.alter f k {-# INLINEABLE alter #-} union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a @@ -143,11 +139,11 @@ {-# INLINEABLE unions #-} map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 -map f = over $ coerceSnowflakeMap . SH.map f +map f = overSM $ coerceSnowflakeMap . SH.map f {-# INLINEABLE map #-} mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 -mapWithKey f = over $ coerceSnowflakeMap . SH.mapWithKey f +mapWithKey f = overSM $ coerceSnowflakeMap . SH.mapWithKey f {-# INLINEABLE mapWithKey #-} traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) @@ -191,19 +187,19 @@ {-# INLINEABLE foldrWithKey #-} filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a -filter f = over $ SH.filter f +filter f = overSM $ SH.filter f {-# INLINEABLE filter #-} filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a -filterWithKey f = over $ SH.filterWithKey f +filterWithKey f = overSM $ SH.filterWithKey f {-# INLINEABLE filterWithKey #-} mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b -mapMaybe f = over $ coerceSnowflakeMap . SH.mapMaybe f +mapMaybe f = overSM $ coerceSnowflakeMap . SH.mapMaybe f {-# INLINEABLE mapMaybe #-} mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b -mapMaybeWithKey f = over $ coerceSnowflakeMap . SH.mapMaybeWithKey f +mapMaybeWithKey f = overSM $ coerceSnowflakeMap . SH.mapMaybeWithKey f {-# INLINEABLE mapMaybeWithKey #-} keys :: SnowflakeMap a -> [Snowflake a] diff --git a/Calamity/Internal/UnixTimestamp.hs b/Calamity/Internal/UnixTimestamp.hs --- a/Calamity/Internal/UnixTimestamp.hs +++ b/Calamity/Internal/UnixTimestamp.hs @@ -7,20 +7,16 @@ import Calamity.Internal.Utils () import Control.Arrow -import Control.DeepSeq (NFData) import Data.Aeson import Data.Aeson.Encoding (word64) import Data.Time import Data.Time.Clock.POSIX import Data.Word -import GHC.Generics import TextShow newtype UnixTimestamp = UnixTimestamp { unUnixTimestamp :: UTCTime } - deriving stock (Generic) - deriving anyclass (NFData) deriving (Show) via UTCTime deriving (TextShow) via FromStringShow UTCTime diff --git a/Calamity/Internal/Updateable.hs b/Calamity/Internal/Updateable.hs --- a/Calamity/Internal/Updateable.hs +++ b/Calamity/Internal/Updateable.hs @@ -6,67 +6,84 @@ import Calamity.Types.Model.Channel.UpdatedMessage import Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.User -import Control.Lens -import Data.Generics.Product.Fields import Data.Maybe import GHC.TypeLits +import Optics class Updateable a where - type Updated a - type Updated a = a + type Updated a + type Updated a = a - update :: Updated a -> a -> a + update :: Updated a -> a -> a -- | sets original field to new field -setF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n b) => n -> o -> o -setF n = field' @f .~ n ^. field' @f +setF :: + forall (f :: Symbol) o n b k. + ( k ~ A_Lens + , LabelOptic' f k o b + , LabelOptic' f k n b + ) => + n -> + o -> + o +setF n = labelOptic @f .~ n ^. labelOptic @f -- | sets original field to unwrapped new field if new field is not Nothing -mergeF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n (Maybe b)) => n -> o -> o -mergeF n = field' @f %~ \oldv -> fromMaybe oldv (n ^. field' @f) +mergeF :: + forall (f :: Symbol) o n b k. + ( k ~ A_Lens + , LabelOptic' f k o b + , LabelOptic' f k n (Maybe b) + ) => + n -> + o -> + o +mergeF n = labelOptic @f %~ \oldv -> fromMaybe oldv (n ^. labelOptic @f) -- | sets original field to new field if new field is not nothing mergeF' :: - forall (f :: Symbol) old new v. - ( HasField' f old (Maybe v) - , HasField' f new (Maybe v) - ) => - new -> - old -> - old -mergeF' new = field' @f %~ \oldv -> lastMaybe oldv (new ^. field' @f) + forall (f :: Symbol) old new v k. + ( k ~ A_Lens + , LabelOptic' f k old (Maybe v) + , LabelOptic' f k new (Maybe v) + ) => + new -> + old -> + old +mergeF' new = labelOptic @f %~ \oldv -> lastMaybe oldv (new ^. labelOptic @f) -- | sets original field to new field if new field was present updateNullableDest :: - forall (f :: Symbol) old new v. - ( HasField' f old (Maybe v) - , HasField' f new (Maybe (MaybeNull v)) - ) => - new -> - old -> - old -updateNullableDest new = case new ^. field' @f of - Just (NotNull x) -> field' @f ?~ x - Just WasNull -> field' @f .~ Nothing - Nothing -> Prelude.id + forall (f :: Symbol) old new v k. + ( k ~ A_Lens + , LabelOptic' f k old (Maybe v) + , LabelOptic' f k new (Maybe (MaybeNull v)) + ) => + new -> + old -> + old +updateNullableDest new = case new ^. labelOptic @f of + Just (NotNull x) -> labelOptic @f ?~ x + Just WasNull -> labelOptic @f .~ Nothing + Nothing -> Prelude.id -- NOTE: afaik only messages get partial updates instance Updateable Message where - type Updated Message = UpdatedMessage + type Updated Message = UpdatedMessage - update n o = o + update n o = + o & mergeF @"content" n & updateNullableDest @"editedTimestamp" n & mergeF @"tts" n & mergeF @"mentionEveryone" n & mergeF @"mentions" n & mergeF @"mentionRoles" n - & mergeF' @"mentionChannels" n + & mergeF @"mentionChannels" n & mergeF @"attachments" n & mergeF @"embeds" n & mergeF @"reactions" n & mergeF @"pinned" n - & updateNullableDest @"webhookID" n & mergeF @"type_" n & updateNullableDest @"activity" n & updateNullableDest @"application" n @@ -77,50 +94,50 @@ & mergeF @"components" n instance Updateable Channel where - update n _ = n + update n _ = n instance Updateable DMChannel where - update n _ = n + update n _ = n instance Updateable GuildChannel where - update n _ = n + update n _ = n instance Updateable Guild where - type Updated Guild = UpdatedGuild + type Updated Guild = UpdatedGuild - update n o = - o - & setF @"name" n - & setF @"icon" n - & setF @"splash" n - & setF @"owner" n - & setF @"ownerID" n - & mergeF @"permissions" n - & setF @"region" n - & setF @"afkChannelID" n - & setF @"afkTimeout" n - & mergeF @"embedEnabled" n - & setF @"embedChannelID" n - & setF @"verificationLevel" n - & setF @"defaultMessageNotifications" n - & setF @"explicitContentFilter" n - & setF @"roles" n - & setF @"features" n - & setF @"mfaLevel" n - & setF @"applicationID" n - & mergeF @"widgetEnabled" n - & setF @"widgetChannelID" n - & setF @"systemChannelID" n + update n o = + o + & setF @"name" n + & setF @"icon" n + & setF @"splash" n + & setF @"owner" n + & setF @"ownerID" n + & mergeF @"permissions" n + & setF @"afkChannelID" n + & setF @"afkTimeout" n + & mergeF @"embedEnabled" n + & setF @"embedChannelID" n + & setF @"verificationLevel" n + & setF @"defaultMessageNotifications" n + & setF @"explicitContentFilter" n + & setF @"roles" n + & setF @"features" n + & setF @"mfaLevel" n + & setF @"applicationID" n + & mergeF @"widgetEnabled" n + & setF @"widgetChannelID" n + & setF @"systemChannelID" n + & setF @"preferredLocale" n instance Updateable User where - update n o = - o - & setF @"username" n - & setF @"discriminator" n - & mergeF' @"bot" n - & mergeF' @"avatar" n - & mergeF' @"mfaEnabled" n - & mergeF' @"verified" n - & mergeF' @"email" n - & mergeF' @"flags" n - & mergeF' @"premiumType" n + update n o = + o + & setF @"username" n + & setF @"discriminator" n + & mergeF' @"bot" n + & mergeF' @"avatar" n + & mergeF' @"mfaEnabled" n + & mergeF' @"verified" n + & mergeF' @"email" n + & mergeF' @"flags" n + & mergeF' @"premiumType" n diff --git a/Calamity/Internal/Utils.hs b/Calamity/Internal/Utils.hs --- a/Calamity/Internal/Utils.hs +++ b/Calamity/Internal/Utils.hs @@ -12,6 +12,8 @@ (<<$>>), (<<*>>), (<.>), + (.?=), + (.=), debug, info, Calamity.Internal.Utils.error, @@ -20,13 +22,14 @@ AesonVector (..), CalamityFromStringShow (..), MaybeNull (..), + CalamityToJSON (..), + CalamityToJSON' (..), ) where -- import Calamity.Internal.RunIntoIO import Calamity.Types.LogEff import Control.Applicative import Control.Monad (when) -import Data.Aeson import Data.Aeson.Encoding (null_) import Data.Default.Class import qualified Data.Map as M @@ -34,10 +37,10 @@ import Data.Text import qualified Data.Vector.Unboxing as VU import qualified DiPolysemy as Di -import GHC.Generics import qualified Polysemy as P import TextShow -import qualified TextShow.Generic as TSG +import qualified Data.Aeson as Aeson +import Data.Maybe (catMaybes) {- | Like whileM, but stateful effects are not preserved to mitigate memory leaks @@ -137,18 +140,18 @@ newtype AesonVector a = AesonVector {unAesonVector :: VU.Vector a} deriving (Show) via VU.Vector a -instance (FromJSON a, VU.Unboxable a) => FromJSON (AesonVector a) where - parseJSON = (AesonVector . VU.fromList <$>) . parseJSON +instance (Aeson.FromJSON a, VU.Unboxable a) => Aeson.FromJSON (AesonVector a) where + parseJSON = (AesonVector . VU.fromList <$>) . Aeson.parseJSON -instance (ToJSON a, VU.Unboxable a) => ToJSON (AesonVector a) where - toJSON = toJSON . VU.toList . unAesonVector - toEncoding = toEncoding . VU.toList . unAesonVector +instance (Aeson.ToJSON a, VU.Unboxable a) => Aeson.ToJSON (AesonVector a) where + toJSON = Aeson.toJSON . VU.toList . unAesonVector + toEncoding = Aeson.toEncoding . VU.toList . unAesonVector instance (TextShow a, VU.Unboxable a) => TextShow (AesonVector a) where showb = showbList . VU.toList . unAesonVector newtype CalamityFromStringShow a = CalamityFromStringShow {unCalamityFromStringShow :: a} - deriving (FromJSON, ToJSON) via a + deriving (Aeson.FromJSON, Aeson.ToJSON) via a deriving (TextShow) via FromStringShow a {- | An alternative 'Maybe' type that allows us to distinguish between parsed @@ -157,16 +160,31 @@ data MaybeNull a = WasNull | NotNull a - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric (MaybeNull a) + deriving (Show) -instance FromJSON a => FromJSON (MaybeNull a) where - parseJSON Null = pure WasNull - parseJSON x = NotNull <$> parseJSON x +instance Aeson.FromJSON a => Aeson.FromJSON (MaybeNull a) where + parseJSON Aeson.Null = pure WasNull + parseJSON x = NotNull <$> Aeson.parseJSON x -instance ToJSON a => ToJSON (MaybeNull a) where - toJSON WasNull = Null - toJSON (NotNull x) = toJSON x +instance Aeson.ToJSON a => Aeson.ToJSON (MaybeNull a) where + toJSON WasNull = Aeson.Null + toJSON (NotNull x) = Aeson.toJSON x toEncoding WasNull = null_ - toEncoding (NotNull x) = toEncoding x + toEncoding (NotNull x) = Aeson.toEncoding x + +(.?=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> Maybe v -> Maybe kv +k .?= Just v = Just (k Aeson..= v) +_ .?= Nothing = Nothing + +(.=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> v -> Maybe kv +k .= v = Just (k Aeson..= v) + +class CalamityToJSON' a where + toPairs :: Aeson.KeyValue kv => a -> [Maybe kv] + +newtype CalamityToJSON a = CalamityToJSON a + +instance CalamityToJSON' a => Aeson.ToJSON (CalamityToJSON a) where + toJSON (CalamityToJSON x) = Aeson.object . catMaybes . toPairs $ x + toEncoding (CalamityToJSON x) = Aeson.pairs . mconcat . catMaybes . toPairs $ x diff --git a/Calamity/Metrics/Eff.hs b/Calamity/Metrics/Eff.hs --- a/Calamity/Metrics/Eff.hs +++ b/Calamity/Metrics/Eff.hs @@ -15,35 +15,27 @@ observeHistogram, ) where -import Calamity.Internal.Utils (DefaultingMap) import Calamity.Metrics.Internal import Data.Default.Class -import Data.Map +import qualified Data.Map as Map import Data.Text -import GHC.Generics +import Optics.TH import Polysemy import TextShow -import Calamity.Internal.OverriddenVia -data HistogramSample' = HistogramSample' - { buckets :: DefaultingMap Double Double - , sum :: Double - , count :: Int - } - deriving (Generic) - deriving (Default) - data HistogramSample = HistogramSample - { buckets :: Map Double Double + { buckets :: Map.Map Double Double , sum :: Double , count :: Int } - deriving (Eq, Show, Generic) - deriving (Default) via OverriddenVia HistogramSample HistogramSample + deriving (Eq, Show) deriving (TextShow) via FromStringShow HistogramSample +instance Default HistogramSample where + def = HistogramSample Map.empty 0.0 0 + data MetricEff m a where -- | Register a 'Counter' RegisterCounter :: @@ -73,3 +65,5 @@ ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample makeSem ''MetricEff + +$(makeFieldLabelsNoPrefix ''HistogramSample) diff --git a/Calamity/Types/LogEff.hs b/Calamity/Types/LogEff.hs --- a/Calamity/Types/LogEff.hs +++ b/Calamity/Types/LogEff.hs @@ -1,15 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | The logging effect we use -module Calamity.Types.LogEff - ( LogEff - , LogC ) where +module Calamity.Types.LogEff ( + LogEff, + LogC, +) where import qualified Df1 -import DiPolysemy +import DiPolysemy -import qualified Polysemy as P +import qualified Polysemy as P type LogEff = Di Df1.Level Df1.Path Df1.Message diff --git a/Calamity/Types/Model.hs b/Calamity/Types/Model.hs --- a/Calamity/Types/Model.hs +++ b/Calamity/Types/Model.hs @@ -1,13 +1,14 @@ -- | Discord data models -module Calamity.Types.Model - ( module Calamity.Types.Model.Channel - , module Calamity.Types.Model.Guild - , module Calamity.Types.Model.Presence - , module Calamity.Types.Model.User - , module Calamity.Types.Model.Voice ) where +module Calamity.Types.Model ( + module Calamity.Types.Model.Channel, + module Calamity.Types.Model.Guild, + module Calamity.Types.Model.Presence, + module Calamity.Types.Model.User, + module Calamity.Types.Model.Voice, +) where -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.Presence -import Calamity.Types.Model.User -import Calamity.Types.Model.Voice +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.Presence +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice diff --git a/Calamity/Types/Model/Channel.hs b/Calamity/Types/Model/Channel.hs --- a/Calamity/Types/Model/Channel.hs +++ b/Calamity/Types/Model/Channel.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | The generic channel type module Calamity.Types.Model.Channel ( Channel (..), @@ -14,7 +16,7 @@ module Calamity.Types.Model.Channel.Component, ) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils import Calamity.Types.Model.Channel.Attachment import Calamity.Types.Model.Channel.ChannelType import Calamity.Types.Model.Channel.Component @@ -27,43 +29,71 @@ import Calamity.Types.Model.Channel.Webhook import Calamity.Types.Model.Guild.Permissions (Permissions) import Calamity.Types.Snowflake -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data Channel = DMChannel' DMChannel | GroupChannel' GroupChannel | GuildChannel' GuildChannel - deriving (Show, Eq, Generic) - deriving (TextShow) via TSG.FromGeneric Channel + deriving (Show, Eq) instance HasID Channel Channel where getID (DMChannel' a) = getID a getID (GroupChannel' a) = getID a getID (GuildChannel' a) = getID a -instance FromJSON Channel where - parseJSON = withObject "Channel" $ \v -> do - type_ <- v .: "type" +instance Aeson.FromJSON Channel where + parseJSON = Aeson.withObject "Channel" $ \v -> do + type_ <- v Aeson..: "type" case type_ of - GuildTextType -> GuildChannel' <$> parseJSON (Object v) - GuildVoiceType -> GuildChannel' <$> parseJSON (Object v) - GuildCategoryType -> GuildChannel' <$> parseJSON (Object v) - DMType -> DMChannel' <$> parseJSON (Object v) - GroupDMType -> GroupChannel' <$> parseJSON (Object v) + GuildTextType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildVoiceType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildCategoryType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + DMType -> DMChannel' <$> Aeson.parseJSON (Aeson.Object v) + GroupDMType -> GroupChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildNewsType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildNewsThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildPublicThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildPrivateThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildStageVoiceType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildDirectoryType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildForumType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) data instance Partial Channel = PartialChannel { id :: Snowflake Channel , name :: Text - , type_ :: !ChannelType + , type_ :: ChannelType , permissions :: Maybe Permissions , parentID :: Maybe (Snowflake Category) } - deriving (Show, Eq, Generic) - deriving (TextShow) via TSG.FromGeneric (Partial Channel) - deriving (ToJSON, FromJSON) via CalamityJSON (Partial Channel) + deriving (Show, Eq) deriving (HasID Channel) via HasIDField "id" (Partial Channel) + deriving (Aeson.ToJSON) via CalamityToJSON (Partial Channel) + +instance CalamityToJSON' (Partial Channel) where + toPairs PartialChannel {..} = + [ "id" .= id + , "name" .= name + , "type" .= type_ + , "permissions" .?= permissions + , "parent_id" .?= parentID + ] + +instance Aeson.FromJSON (Partial Channel) where + parseJSON = Aeson.withObject "Partial Channel" $ \v -> + PartialChannel + <$> v .: "id" + <*> v .: "name" + <*> v .: "type" + <*> v .:? "permissions" + <*> v .:? "parent_id" + +$(deriveTextShow ''Channel) +$(deriveTextShow 'PartialChannel) +$(makeFieldLabelsNoPrefix ''Channel) +$(makeFieldLabelsNoPrefix 'PartialChannel) diff --git a/Calamity/Types/Model/Channel/Attachment.hs b/Calamity/Types/Model/Channel/Attachment.hs --- a/Calamity/Types/Model/Channel/Attachment.hs +++ b/Calamity/Types/Model/Channel/Attachment.hs @@ -1,15 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Message attachments module Calamity.Types.Model.Channel.Attachment ( Attachment (..), ) where import Calamity.Types.Snowflake -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH fuseTup2 :: Monad f => (f a, f b) -> f (a, b) fuseTup2 (a, b) = do @@ -19,36 +21,28 @@ data Attachment = Attachment { id :: Snowflake Attachment - , filename :: !Text + , filename :: Text , size :: Word64 - , url :: !Text - , proxyUrl :: !Text - , dimensions :: !(Maybe (Word64, Word64)) + , url :: Text + , proxyUrl :: Text + , dimensions :: Maybe (Word64, Word64) } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric Attachment + deriving (Eq, Show) deriving (HasID Attachment) via HasIDField "id" Attachment -instance ToJSON Attachment where - toJSON Attachment {id, filename, size, url, proxyUrl, dimensions = Just (width, height)} = - object - [ "id" .= id - , "filename" .= filename - , "size" .= size - , "url" .= url - , "proxy_url" .= proxyUrl - , "width" .= width - , "height" .= height - ] - toJSON Attachment {id, filename, size, url, proxyUrl} = - object ["id" .= id, "filename" .= filename, "size" .= size, "url" .= url, "proxy_url" .= proxyUrl] +$(deriveTextShow ''Attachment) +$(makeFieldLabelsNoPrefix ''Attachment) -instance FromJSON Attachment where - parseJSON = withObject "Attachment" $ \v -> do +instance Aeson.FromJSON Attachment where + parseJSON = Aeson.withObject "Attachment" $ \v -> do width <- v .:? "width" height <- v .:? "height" - Attachment <$> v .: "id" <*> v .: "filename" <*> v .: "size" <*> v .: "url" <*> v .: "proxy_url" + Attachment + <$> v .: "id" + <*> v .: "filename" + <*> v .: "size" + <*> v .: "url" + <*> v .: "proxy_url" <*> pure (fuseTup2 (width, height)) - diff --git a/Calamity/Types/Model/Channel/ChannelType.hs b/Calamity/Types/Model/Channel/ChannelType.hs --- a/Calamity/Types/Model/Channel/ChannelType.hs +++ b/Calamity/Types/Model/Channel/ChannelType.hs @@ -1,13 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Types of channels module Calamity.Types.Model.Channel.ChannelType (ChannelType (..)) where -import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Scientific - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH -- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182) data ChannelType @@ -16,18 +15,36 @@ | GuildVoiceType | GroupDMType | GuildCategoryType - deriving (Eq, Generic, Show, Enum) - deriving (TextShow) via TSG.FromGeneric ChannelType + | GuildNewsType + | GuildNewsThreadType + | GuildPublicThreadType + | GuildPrivateThreadType + | GuildStageVoiceType + | GuildDirectoryType + | GuildForumType + deriving (Eq, Show, Enum) -instance ToJSON ChannelType where - toJSON t = Number $ fromIntegral (fromEnum t) +$(deriveTextShow ''ChannelType) +$(makeFieldLabelsNoPrefix ''ChannelType) -instance FromJSON ChannelType where - parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of +instance Aeson.ToJSON ChannelType where + toJSON t = Aeson.toJSON (fromEnum t) + toEncoding t = Aeson.toEncoding (fromEnum t) + +instance Aeson.FromJSON ChannelType where + parseJSON = Aeson.withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of Just v -> case v of 0 -> pure GuildTextType 1 -> pure DMType 2 -> pure GuildVoiceType + 3 -> pure GroupDMType 4 -> pure GuildCategoryType + 5 -> pure GuildNewsType + 10 -> pure GuildNewsThreadType + 11 -> pure GuildPublicThreadType + 12 -> pure GuildPrivateThreadType + 13 -> pure GuildStageVoiceType + 14 -> pure GuildDirectoryType + 15 -> pure GuildForumType _ -> fail $ "Invalid ChannelType: " <> show n Nothing -> fail $ "Invalid ChannelType: " <> show n diff --git a/Calamity/Types/Model/Channel/Component.hs b/Calamity/Types/Model/Channel/Component.hs --- a/Calamity/Types/Model/Channel/Component.hs +++ b/Calamity/Types/Model/Channel/Component.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Message components module Calamity.Types.Model.Channel.Component ( CustomID (..), @@ -20,77 +22,83 @@ componentType, ) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Calamity.Types.Model.Guild.Emoji import Control.Monad (replicateM) -import Data.Aeson +import Data.Aeson ((.!=), (.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Scientific (toBoundedInteger) import qualified Data.Text as T -import GHC.Generics +import Optics.TH import System.Random (Uniform) import System.Random.Stateful (Uniform (uniformM), UniformRange (uniformRM)) -import TextShow -import qualified TextShow.Generic as TSG +import TextShow.TH +import Data.Maybe (catMaybes) newtype CustomID = CustomID T.Text - deriving stock (Eq, Ord, Show, Generic) - deriving (TextShow) via TSG.FromGeneric CustomID - deriving (ToJSON, FromJSON) via T.Text + deriving stock (Eq, Ord, Show) + deriving (Aeson.ToJSON, Aeson.FromJSON) via T.Text +$(deriveTextShow ''CustomID) + instance Uniform CustomID where uniformM = ((CustomID . T.pack) <$>) . replicateM 16 . uniformRM ('a', 'z') -data Button = Button - { style :: ButtonStyle - , label :: Maybe T.Text - , emoji :: Maybe RawEmoji - , disabled :: Bool - , customID :: CustomID - } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric Button - deriving (ToJSON) via CalamityJSONKeepNothing Button - deriving - (FromJSON) - via WithSpecialCases - '["disabled" `IfNoneThen` DefaultToFalse] - Button +data ComponentType + = ActionRowType + | ButtonType + | SelectType + | TextInputType + deriving (Eq, Show) -data LinkButton = LinkButton - { stype :: ButtonStyle - , label :: Maybe T.Text - , emoji :: Maybe RawEmoji - , url :: T.Text - , disabled :: Bool - } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric LinkButton - deriving (ToJSON) via CalamityJSONKeepNothing LinkButton - deriving - (FromJSON) - via WithSpecialCases - '["disabled" `IfNoneThen` DefaultToFalse] - LinkButton +$(deriveTextShow ''ComponentType) +instance Aeson.ToJSON ComponentType where + toJSON x = Aeson.toJSON @Int $ case x of + ActionRowType -> 1 + ButtonType -> 2 + SelectType -> 3 + TextInputType -> 4 + toEncoding x = Aeson.toEncoding @Int $ case x of + ActionRowType -> 1 + ButtonType -> 2 + SelectType -> 3 + TextInputType -> 4 + +instance Aeson.FromJSON ComponentType where + parseJSON = Aeson.withScientific "Components.ComponentType" $ \n -> case toBoundedInteger @Int n of + Just 1 -> pure ActionRowType + Just 2 -> pure ButtonType + Just 3 -> pure SelectType + Just 4 -> pure TextInputType + _ -> fail $ "Invalid ComponentType: " <> show n + data ButtonStyle = ButtonPrimary | ButtonSecondary | ButtonSuccess | ButtonDanger | ButtonLink - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric ButtonStyle + deriving (Eq, Show) -instance ToJSON ButtonStyle where - toJSON t = toJSON @Int $ case t of +$(deriveTextShow ''ButtonStyle) + +instance Aeson.ToJSON ButtonStyle where + toJSON t = Aeson.toJSON @Int $ case t of ButtonPrimary -> 1 ButtonSecondary -> 2 ButtonSuccess -> 3 ButtonDanger -> 4 ButtonLink -> 5 + toEncoding t = Aeson.toEncoding @Int $ case t of + ButtonPrimary -> 1 + ButtonSecondary -> 2 + ButtonSuccess -> 3 + ButtonDanger -> 4 + ButtonLink -> 5 -instance FromJSON ButtonStyle where - parseJSON = withScientific "ButtonStyle" $ \n -> case toBoundedInteger @Int n of +instance Aeson.FromJSON ButtonStyle where + parseJSON = Aeson.withScientific "Components.ButtonStyle" $ \n -> case toBoundedInteger @Int n of Just v -> case v of 1 -> pure ButtonPrimary 2 -> pure ButtonSecondary @@ -100,6 +108,71 @@ _ -> fail $ "Invalid ButtonStyle: " <> show n Nothing -> fail $ "Invalid ButtonStyle: " <> show n +data Button = Button + { style :: ButtonStyle + , label :: Maybe T.Text + , emoji :: Maybe RawEmoji + , disabled :: Bool + , customID :: CustomID + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON Button + +instance CalamityToJSON' Button where + toPairs Button {..} = + [ "style" .= style + , "label" .?= label + , "emoji" .?= emoji + , "disabled" .= disabled + , "custom_id" .= customID + , "type" .= ButtonType + ] + +$(deriveTextShow ''Button) +$(makeFieldLabelsNoPrefix ''Button) + + +instance Aeson.FromJSON Button where + parseJSON = Aeson.withObject "Components.Button" $ \v -> + Button + <$> v .: "style" + <*> v .:? "label" + <*> v .:? "emoji" + <*> v .:? "disabled" .!= False + <*> v .: "custom_id" + +data LinkButton = LinkButton + { style :: ButtonStyle + , label :: Maybe T.Text + , emoji :: Maybe RawEmoji + , url :: T.Text + , disabled :: Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON LinkButton + +instance CalamityToJSON' LinkButton where + toPairs LinkButton {..} = + [ "style" .= style + , "label" .?= label + , "emoji" .?= emoji + , "url" .= url + , "disabled" .= disabled + , "type" .= ButtonType + ] + +instance Aeson.FromJSON LinkButton where + parseJSON = Aeson.withObject "Components.Linkbutton" $ \v -> + LinkButton + <$> v .: "style" + <*> v .:? "label" + <*> v .:? "emoji" + <*> v .: "url" + <*> v .:? "disabled" .!= False + +$(deriveTextShow ''LinkButton) +$(makeFieldLabelsNoPrefix ''LinkButton) + {- | Constuct a non-disabled 'Button' with the given 'ButtonStyle' and 'CustomID', all other fields are set to 'Nothing' -} @@ -134,6 +207,37 @@ LinkButton lbutton' s lnk lbl = LinkButton s (Just lbl) Nothing lnk False +data SelectOption = SelectOption + { label :: T.Text + , value :: T.Text + , description :: Maybe T.Text + , emoji :: Maybe RawEmoji + , default_ :: Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON SelectOption + +instance CalamityToJSON' SelectOption where + toPairs SelectOption {..} = + [ "label" .= label + , "value" .= value + , "description" .?= description + , "emoji" .?= emoji + , "default" .= default_ + ] + +instance Aeson.FromJSON SelectOption where + parseJSON = Aeson.withObject "Components.SelectOption" $ \v -> + SelectOption + <$> v .: "label" + <*> v .: "value" + <*> v .:? "description" + <*> v .:? "emoji" + <*> v .:? "default" .!= False + +$(deriveTextShow ''SelectOption) +$(makeFieldLabelsNoPrefix ''SelectOption) + data Select = Select { options :: [SelectOption] , placeholder :: Maybe T.Text @@ -142,31 +246,33 @@ , disabled :: Bool , customID :: CustomID } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric Select - deriving (ToJSON) via CalamityJSONKeepNothing Select - deriving - (FromJSON) - via WithSpecialCases - '["disabled" `IfNoneThen` DefaultToFalse] - Select + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON Select -data SelectOption = SelectOption - { label :: T.Text - , value :: T.Text - , description :: Maybe T.Text - , emoji :: Maybe RawEmoji - , default_ :: Bool - } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric SelectOption - deriving (ToJSON) via CalamityJSONKeepNothing SelectOption - deriving - (FromJSON) - via WithSpecialCases - '["default" `IfNoneThen` DefaultToFalse] - SelectOption +instance CalamityToJSON' Select where + toPairs Select {..} = + [ "options" .= options + , "placeholder" .?= placeholder + , "min_values" .?= minValues + , "max_values" .?= maxValues + , "disabled" .= disabled + , "custom_id" .= customID + , "type" .= SelectType + ] +instance Aeson.FromJSON Select where + parseJSON = Aeson.withObject "Components.Select" $ \v -> + Select + <$> v .: "options" + <*> v .:? "placeholder" + <*> v .:? "min_values" + <*> v .:? "max_values" + <*> v .:? "disabled" .!= False + <*> v .: "custom_id" + +$(deriveTextShow ''Select) +$(makeFieldLabelsNoPrefix ''Select) + select :: [SelectOption] -> CustomID -> Select select o = Select o Nothing Nothing Nothing False @@ -178,6 +284,29 @@ SelectOption sopt l v = SelectOption l v Nothing Nothing False +data TextInputStyle + = TextInputShort + | TextInputParagraph + deriving (Show) + +$(deriveTextShow ''TextInputStyle) + +instance Aeson.ToJSON TextInputStyle where + toJSON t = Aeson.toJSON @Int $ case t of + TextInputShort -> 1 + TextInputParagraph -> 2 + toEncoding t = Aeson.toEncoding @Int $ case t of + TextInputShort -> 1 + TextInputParagraph -> 2 + +instance Aeson.FromJSON TextInputStyle where + parseJSON = Aeson.withScientific "Components.TextInputStyle" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 1 -> pure TextInputShort + 2 -> pure TextInputParagraph + _ -> fail $ "Invalid TextInputStyle: " <> show n + Nothing -> fail $ "Invalid TextInputStyle: " <> show n + data TextInput = TextInput { style :: TextInputStyle , label :: T.Text @@ -188,33 +317,36 @@ , placeholder :: Maybe T.Text , customID :: CustomID } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric TextInput - deriving (ToJSON) via CalamityJSONKeepNothing TextInput - deriving - (FromJSON) - via WithSpecialCases - '["required" `IfNoneThen` DefaultToFalse] - TextInput + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON TextInput -data TextInputStyle - = TextInputShort - | TextInputParagraph - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric TextInputStyle +instance CalamityToJSON' TextInput where + toPairs TextInput {..} = + [ "style" .= style + , "label" .= label + , "min_length" .= minLength + , "max_length" .= maxLength + , "required" .= required + , "value" .= value + , "placeholder" .= placeholder + , "custom_id" .= customID + , "type" .= TextInputType + ] -instance ToJSON TextInputStyle where - toJSON t = toJSON @Int $ case t of - TextInputShort -> 1 - TextInputParagraph -> 2 +instance Aeson.FromJSON TextInput where + parseJSON = Aeson.withObject "Components.TextInput" $ \v -> + TextInput + <$> v .: "style" + <*> v .: "label" + <*> v .:? "min_length" + <*> v .:? "max_length" + <*> v .:? "required" .!= False + <*> v .:? "value" + <*> v .:? "placeholder" + <*> v .: "custom_id" -instance FromJSON TextInputStyle where - parseJSON = withScientific "TextInputStyle" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of - 1 -> pure TextInputShort - 2 -> pure TextInputParagraph - _ -> fail $ "Invalid TextInputStyle: " <> show n - Nothing -> fail $ "Invalid TextInputStyle: " <> show n +$(deriveTextShow ''TextInput) +$(makeFieldLabelsNoPrefix ''TextInput) textInput :: TextInputStyle -> @@ -230,35 +362,42 @@ | LinkButton' LinkButton | Select' Select | TextInput' TextInput - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric Component + deriving (Show) -instance ToJSON Component where +$(deriveTextShow ''Component) + +instance Aeson.ToJSON Component where toJSON t = - let (Object inner, type_) = case t of - ActionRow' xs -> (Object ("components" .= xs), 1 :: Int) - Button' b -> (toJSON b, 2 :: Int) - LinkButton' lb -> (toJSON lb, 2 :: Int) - Select' s -> (toJSON s, 3 :: Int) - TextInput' ti -> (toJSON ti, 4 :: Int) - in Object (inner <> ("type" .= type_)) + case t of + ActionRow' xs -> Aeson.object . catMaybes $ ["components" .= xs, "type" .= ActionRowType] + Button' b -> Aeson.toJSON b + LinkButton' lb -> Aeson.toJSON lb + Select' s -> Aeson.toJSON s + TextInput' ti -> Aeson.toJSON ti -instance FromJSON Component where - parseJSON = withObject "Component" $ \v -> do - type_ :: Int <- v .: "type" + toEncoding t = + case t of + ActionRow' xs -> Aeson.pairs . mconcat . catMaybes $ ["components" .= xs, "type" .= ActionRowType] + Button' b -> Aeson.toEncoding b + LinkButton' lb -> Aeson.toEncoding lb + Select' s -> Aeson.toEncoding s + TextInput' ti -> Aeson.toEncoding ti +instance Aeson.FromJSON Component where + parseJSON = Aeson.withObject "Component" $ \v -> do + type_ :: ComponentType <- v .: "type" + case type_ of - 1 -> ActionRow' <$> v .: "components" - 2 -> do + ActionRowType -> ActionRow' <$> v .: "components" + ButtonType -> do cid :: Maybe CustomID <- v .:? "custom_id" url :: Maybe T.Text <- v .:? "url" case (cid, url) of - (Just _, _) -> Button' <$> parseJSON (Object v) - (_, Just _) -> LinkButton' <$> parseJSON (Object v) + (Just _, _) -> Button' <$> Aeson.parseJSON (Aeson.Object v) + (_, Just _) -> LinkButton' <$> Aeson.parseJSON (Aeson.Object v) _ -> fail $ "Impossible button: " <> show v - 3 -> Select' <$> parseJSON (Object v) - 4 -> TextInput' <$> parseJSON (Object v) - _ -> fail $ "Invalid ComponentType: " <> show type_ + SelectType -> Select' <$> Aeson.parseJSON (Aeson.Object v) + TextInputType -> TextInput' <$> Aeson.parseJSON (Aeson.Object v) componentType :: Component -> ComponentType componentType (ActionRow' _) = ActionRowType @@ -266,26 +405,3 @@ componentType (LinkButton' _) = ButtonType componentType (Select' _) = SelectType componentType (TextInput' _) = TextInputType - -data ComponentType - = ActionRowType - | ButtonType - | SelectType - | TextInputType - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric ComponentType - -instance ToJSON ComponentType where - toJSON x = toJSON @Int $ case x of - ActionRowType -> 1 - ButtonType -> 2 - SelectType -> 3 - TextInputType -> 4 - -instance FromJSON ComponentType where - parseJSON = withScientific "ComponentType" $ \n -> case toBoundedInteger @Int n of - Just 1 -> pure ActionRowType - Just 2 -> pure ButtonType - Just 3 -> pure SelectType - Just 4 -> pure TextInputType - _ -> fail $ "Invalid ComponentType: " <> show n diff --git a/Calamity/Types/Model/Channel/DM.hs b/Calamity/Types/Model/Channel/DM.hs --- a/Calamity/Types/Model/Channel/DM.hs +++ b/Calamity/Types/Model/Channel/DM.hs @@ -1,42 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | A DM channel with a single person module Calamity.Types.Model.Channel.DM (DMChannel (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Time -import Data.Vector.Unboxing (Vector) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data DMChannel' = DMChannel' - { id :: Snowflake DMChannel - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime) - , recipients :: AesonVector (Snowflake User) - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric DMChannel' - deriving - (FromJSON) - via WithSpecialCases - '["recipients" `ExtractArrayField` "id"] - DMChannel' +import Optics.TH +import qualified TextShow data DMChannel = DMChannel { id :: Snowflake DMChannel , lastMessageID :: Maybe (Snowflake Message) , lastPinTimestamp :: Maybe UTCTime - , recipients :: Vector (Snowflake User) + , recipients :: [User] } - deriving (Show, Eq, Generic, NFData) - deriving (TextShow, FromJSON) via OverriddenVia DMChannel DMChannel' + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow DMChannel deriving (HasID DMChannel) via HasIDField "id" DMChannel deriving (HasID Channel) via HasIDFieldCoerce' "id" DMChannel + +instance Aeson.FromJSON DMChannel where + parseJSON = Aeson.withObject "DMChannel" $ \v -> + DMChannel + <$> v .: "id" + <*> v .:? "last_pin_timestamp" + <*> v .:? "last_message_id" + <*> v .: "recipients" + +$(makeFieldLabelsNoPrefix ''DMChannel) diff --git a/Calamity/Types/Model/Channel/Embed.hs b/Calamity/Types/Model/Channel/Embed.hs --- a/Calamity/Types/Model/Channel/Embed.hs +++ b/Calamity/Types/Model/Channel/Embed.hs @@ -1,105 +1,130 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Message embeds module Calamity.Types.Model.Channel.Embed ( - Embed (..), - embedFooter, - embedImage, - embedThumbnail, - embedAuthor, - embedAuthor', - embedField, - EmbedFooter (..), - EmbedImage (..), - EmbedThumbnail (..), - EmbedVideo (..), - EmbedProvider (..), - EmbedAuthor (..), - EmbedField (..), + Embed (..), + embedFooter, + embedImage, + embedThumbnail, + embedAuthor, + embedAuthor', + embedField, + EmbedFooter (..), + EmbedImage (..), + EmbedThumbnail (..), + EmbedVideo (..), + EmbedProvider (..), + EmbedAuthor (..), + EmbedField (..), ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.IntColour -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils -import Control.Lens -import Data.Aeson +import Calamity.Internal.IntColour (IntColour (..)) +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Data.Aeson ((.!=), (.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Colour (Colour) import Data.Default.Class -import Data.Generics.Labels () import Data.Semigroup import Data.Text (Text) import Data.Time import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data Embed' = Embed' - { title :: Maybe Text - , type_ :: Maybe Text - , description :: Maybe Text - , url :: Maybe Text - , timestamp :: Maybe (CalamityFromStringShow UTCTime) - , color :: Maybe IntColour - , footer :: Maybe EmbedFooter - , image :: Maybe EmbedImage - , thumbnail :: Maybe EmbedThumbnail - , video :: Maybe EmbedVideo - , provider :: Maybe EmbedProvider - , author :: Maybe EmbedAuthor - , fields :: [EmbedField] - } - deriving (Generic) - deriving (FromJSON) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed' - deriving (ToJSON) via CalamityJSON Embed' - deriving (TextShow) via TSG.FromGeneric Embed' +import Optics ((%~), (&), (^.)) +import Optics.TH +import qualified TextShow +import TextShow.TH data Embed = Embed - { title :: Maybe Text - , type_ :: Maybe Text - , description :: Maybe Text - , url :: Maybe Text - , timestamp :: Maybe UTCTime - , color :: Maybe (Colour Double) - , footer :: Maybe EmbedFooter - , image :: Maybe EmbedImage - , thumbnail :: Maybe EmbedThumbnail - , video :: Maybe EmbedVideo - , provider :: Maybe EmbedProvider - , author :: Maybe EmbedAuthor - , fields :: [EmbedField] - } - deriving (Eq, Show, Generic, Default) - deriving (TextShow, FromJSON, ToJSON) via OverriddenVia Embed Embed' + { title :: Maybe Text + , type_ :: Maybe Text + , description :: Maybe Text + , url :: Maybe Text + , timestamp :: Maybe UTCTime + , color :: Maybe (Colour Double) + , footer :: Maybe EmbedFooter + , image :: Maybe EmbedImage + , thumbnail :: Maybe EmbedThumbnail + , video :: Maybe EmbedVideo + , provider :: Maybe EmbedProvider + , author :: Maybe EmbedAuthor + , fields :: [EmbedField] + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Embed + deriving (Aeson.ToJSON) via CalamityToJSON Embed -instance Semigroup Embed where - l <> r = - l - & #title %~ (<> (r ^. #title)) - & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last - & #description %~ (<> (r ^. #description)) - & #url %~ getLast . (<> Last (r ^. #url)) . Last - & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last - & #color %~ getLast . (<> Last (r ^. #color)) . Last - & #footer %~ (<> (r ^. #footer)) - & #image %~ getLast . (<> Last (r ^. #image)) . Last - & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last - & #video %~ getLast . (<> Last (r ^. #video)) . Last - & #provider %~ getLast . (<> Last (r ^. #provider)) . Last - & #author %~ getLast . (<> Last (r ^. #author)) . Last - & #fields %~ (<> (r ^. #fields)) +instance Default Embed where + def = + Embed + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + [] -instance Monoid Embed where - mempty = def +instance CalamityToJSON' Embed where + toPairs Embed {..} = + [ "title" .?= title + , "type" .?= type_ + , "description" .?= description + , "url" .?= url + , "timestamp" .?= timestamp + , "color" .?= (IntColour <$> color) + , "footer" .?= footer + , "image" .?= image + , "thumbnail" .?= thumbnail + , "video" .?= video + , "provider" .?= provider + , "author" .?= author + , "fields" .= fields + ] +instance Aeson.FromJSON Embed where + parseJSON = Aeson.withObject "Embed" $ \v -> + Embed + <$> v .:? "title" + <*> v .:? "type" + <*> v .:? "description" + <*> v .:? "url" + <*> v .:? "timestamp" + <*> (fmap fromIntColour <$> v .:? "color") + <*> v .:? "footer" + <*> v .:? "image" + <*> v .:? "thumbnail" + <*> v .:? "video" + <*> v .:? "provider" + <*> v .:? "author" + <*> v .:? "fields" .!= [] + data EmbedFooter = EmbedFooter - { text :: Text - , iconUrl :: Maybe Text - , proxyIconUrl :: Maybe Text - } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric EmbedFooter - deriving (ToJSON, FromJSON) via CalamityJSON EmbedFooter + { text :: Text + , iconUrl :: Maybe Text + , proxyIconUrl :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedFooter +instance CalamityToJSON' EmbedFooter where + toPairs EmbedFooter {..} = + [ "text" .= text + , "icon_url" .?= iconUrl + , "proxy_icon_url" .?= proxyIconUrl + ] + +instance Aeson.FromJSON EmbedFooter where + parseJSON = Aeson.withObject "EmbedFooter" $ \v -> + EmbedFooter + <$> v .: "text" + <*> v .:? "icon_url" + <*> v .:? "proxy_icon_url" + {- | Create an embed footer with a provided content The remaining fields are set to Nothing @@ -107,23 +132,31 @@ embedFooter :: Text -> EmbedFooter embedFooter text = EmbedFooter text Nothing Nothing -instance Semigroup EmbedFooter where - l <> r = - l - & #text %~ (<> (r ^. #text)) - & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last - & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last - data EmbedImage = EmbedImage - { url :: Text - , proxyUrl :: Maybe Text - , width :: Maybe Word64 - , height :: Maybe Word64 - } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric EmbedImage - deriving (FromJSON, ToJSON) via CalamityJSON EmbedImage + { url :: Text + , proxyUrl :: Maybe Text + , width :: Maybe Word64 + , height :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedImage +instance CalamityToJSON' EmbedImage where + toPairs EmbedImage {..} = + [ "url" .= url + , "proxy_url" .= proxyUrl + , "width" .= width + , "height" .= height + ] + +instance Aeson.FromJSON EmbedImage where + parseJSON = Aeson.withObject "EmbedImage" $ \v -> + EmbedImage + <$> v .: "url" + <*> v .:? "proxy_url" + <*> v .:? "width" + <*> v .:? "height" + {- | Create an embed image with a provided url The remaining fields are set to Nothing @@ -132,15 +165,30 @@ embedImage url = EmbedImage url Nothing Nothing Nothing data EmbedThumbnail = EmbedThumbnail - { url :: Text - , proxyUrl :: Maybe Text - , width :: Maybe Word64 - , height :: Maybe Word64 - } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric EmbedThumbnail - deriving (FromJSON, ToJSON) via CalamityJSON EmbedThumbnail + { url :: Text + , proxyUrl :: Maybe Text + , width :: Maybe Word64 + , height :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedThumbnail +instance CalamityToJSON' EmbedThumbnail where + toPairs EmbedThumbnail {..} = + [ "url" .= url + , "proxy_url" .?= proxyUrl + , "width" .?= width + , "height" .?= height + ] + +instance Aeson.FromJSON EmbedThumbnail where + parseJSON = Aeson.withObject "EmbedThumbnail" $ \v -> + EmbedThumbnail + <$> v .: "url" + <*> v .:? "proxy_url" + <*> v .:? "width" + <*> v .:? "height" + {- | Create an embed thumbnail with a provided url The remaining fields are set to Nothing @@ -149,33 +197,77 @@ embedThumbnail url = EmbedThumbnail url Nothing Nothing Nothing data EmbedVideo = EmbedVideo - { url :: Maybe Text - , proxyUrl :: Maybe Text - , width :: Maybe Word64 - , height :: Maybe Word64 - } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric EmbedVideo - deriving (FromJSON, ToJSON) via CalamityJSON EmbedVideo + { url :: Maybe Text + , proxyUrl :: Maybe Text + , width :: Maybe Word64 + , height :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedVideo +instance CalamityToJSON' EmbedVideo where + toPairs EmbedVideo {..} = + [ "url" .= url + , "proxy_url" .= proxyUrl + , "width" .= width + , "height" .= height + ] + +instance Aeson.FromJSON EmbedVideo where + parseJSON = Aeson.withObject "EmbedVideo" $ \v -> + EmbedVideo + <$> v .: "url" + <*> v .:? "proxy_url" + <*> v .:? "width" + <*> v .:? "height" + data EmbedProvider = EmbedProvider - { name :: Maybe Text - , url :: Maybe Text - } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric EmbedProvider - deriving (ToJSON, FromJSON) via CalamityJSON EmbedProvider + { name :: Maybe Text + , url :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedProvider +instance CalamityToJSON' EmbedProvider where + toPairs EmbedProvider {..} = + [ "name" .= name + , "url" .= url + ] + +instance Aeson.FromJSON EmbedProvider where + parseJSON = Aeson.withObject "EmbedProvider" $ \v -> + EmbedProvider + <$> v .:? "name" + <*> v .:? "url" + data EmbedAuthor = EmbedAuthor - { name :: Maybe Text - , url :: Maybe Text - , iconUrl :: Maybe Text - , proxyIconURL :: Maybe Text - } - deriving (Eq, Show, Generic, Default) - deriving (TextShow) via TSG.FromGeneric EmbedAuthor - deriving (ToJSON, FromJSON) via CalamityJSON EmbedAuthor + { name :: Maybe Text + , url :: Maybe Text + , iconUrl :: Maybe Text + , proxyIconUrl :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedAuthor +instance Default EmbedAuthor where + def = EmbedAuthor Nothing Nothing Nothing Nothing + +instance CalamityToJSON' EmbedAuthor where + toPairs EmbedAuthor {..} = + [ "name" .?= name + , "url" .?= url + , "icon_url" .?= iconUrl + , "proxy_icon_url" .?= proxyIconUrl + ] + +instance Aeson.FromJSON EmbedAuthor where + parseJSON = Aeson.withObject "EmbedAuthor" $ \v -> + EmbedAuthor + <$> v .:? "name" + <*> v .:? "url" + <*> v .:? "icon_url" + <*> v .:? "proxy_icon_url" + {- | Create an embed author with the given name The remaining fields are set to Nothing @@ -188,34 +280,92 @@ The remaining fields are set to Nothing -} embedAuthor' :: - -- | Name - Text -> - -- | Url - Text -> - -- | Icon url - Text -> - EmbedAuthor + -- | Name + Text -> + -- | Url + Text -> + -- | Icon url + Text -> + EmbedAuthor embedAuthor' name url iconUrl = EmbedAuthor (Just name) (Just url) (Just iconUrl) Nothing data EmbedField = EmbedField - { name :: Text - , value :: Text - , inline :: Bool - } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric EmbedField - deriving - (FromJSON) - via WithSpecialCases - '[IfNoneThen "inline" DefaultToFalse] - EmbedField - deriving (ToJSON) via CalamityJSON EmbedField + { name :: Text + , value :: Text + , inline :: Bool + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedField +instance CalamityToJSON' EmbedField where + toPairs EmbedField {..} = + [ "name" .= name + , "value" .= value + , "inline" .= inline + ] + +instance Aeson.FromJSON EmbedField where + parseJSON = Aeson.withObject "EmbedField" $ \v -> + EmbedField + <$> v .: "name" + <*> v .: "value" + <*> v .:? "inline" .!= False + -- | Create a non-inline embed field embedField :: - -- | Name - Text -> - -- | Value - Text -> - EmbedField + -- | Name + Text -> + -- | Value + Text -> + EmbedField embedField name value = EmbedField name value False + +$(makeFieldLabelsNoPrefix ''Embed) + +$(deriveTextShow ''EmbedFooter) +$(makeFieldLabelsNoPrefix ''EmbedFooter) + +$(deriveTextShow ''EmbedImage) +$(makeFieldLabelsNoPrefix ''EmbedImage) + +$(deriveTextShow ''EmbedThumbnail) +$(makeFieldLabelsNoPrefix ''EmbedThumbnail) + +$(deriveTextShow ''EmbedVideo) +$(makeFieldLabelsNoPrefix ''EmbedVideo) + +$(deriveTextShow ''EmbedProvider) +$(makeFieldLabelsNoPrefix ''EmbedProvider) + +$(deriveTextShow ''EmbedAuthor) +$(makeFieldLabelsNoPrefix ''EmbedAuthor) + +$(deriveTextShow ''EmbedField) +$(makeFieldLabelsNoPrefix ''EmbedField) + +instance Semigroup EmbedFooter where + l <> r = + l + & #text %~ (<> (r ^. #text)) + & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last + & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last + +instance Semigroup Embed where + l <> r = + l + & #title %~ (<> (r ^. #title)) + & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last + & #description %~ (<> (r ^. #description)) + & #url %~ getLast . (<> Last (r ^. #url)) . Last + & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last + & #color %~ getLast . (<> Last (r ^. #color)) . Last + & #footer %~ (<> (r ^. #footer)) + & #image %~ getLast . (<> Last (r ^. #image)) . Last + & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last + & #video %~ getLast . (<> Last (r ^. #video)) . Last + & #provider %~ getLast . (<> Last (r ^. #provider)) . Last + & #author %~ getLast . (<> Last (r ^. #author)) . Last + & #fields %~ (<> (r ^. #fields)) + +instance Monoid Embed where + mempty = def diff --git a/Calamity/Types/Model/Channel/Group.hs b/Calamity/Types/Model/Channel/Group.hs --- a/Calamity/Types/Model/Channel/Group.hs +++ b/Calamity/Types/Model/Channel/Group.hs @@ -1,33 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | A Group Group channel module Calamity.Types.Model.Channel.Group (GroupChannel (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Time -import Data.Vector.Unboxing (Vector) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data GroupChannel' = GroupChannel' - { id :: Snowflake GroupChannel - , ownerID :: Snowflake User - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime) - , icon :: Maybe Text - , recipients :: AesonVector (Snowflake User) - , name :: Text - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric GroupChannel' - deriving (ToJSON, FromJSON) via CalamityJSON GroupChannel' +import Optics.TH +import qualified TextShow data GroupChannel = GroupChannel { id :: Snowflake GroupChannel @@ -35,11 +20,24 @@ , lastMessageID :: Maybe (Snowflake Message) , lastPinTimestamp :: Maybe UTCTime , icon :: Maybe Text - , recipients :: Vector (Snowflake User) + , recipients :: [User] , name :: Text } - deriving (Show, Eq, Generic) - deriving (TextShow, ToJSON, FromJSON) via OverriddenVia GroupChannel GroupChannel' + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow GroupChannel deriving (HasID GroupChannel) via HasIDField "id" GroupChannel deriving (HasID Channel) via HasIDFieldCoerce' "id" GroupChannel deriving (HasID User) via HasIDField "ownerID" GroupChannel + +$(makeFieldLabelsNoPrefix ''GroupChannel) + +instance Aeson.FromJSON GroupChannel where + parseJSON = Aeson.withObject "GroupChannel" $ \v -> + GroupChannel + <$> v .: "id" + <*> v .: "owner_id" + <*> v .:? "last_message_id" + <*> v .:? "last_pin_timestamp" + <*> v .:? "icon" + <*> v .: "recipients" + <*> v .: "name" diff --git a/Calamity/Types/Model/Channel/Guild.hs b/Calamity/Types/Model/Channel/Guild.hs --- a/Calamity/Types/Model/Channel/Guild.hs +++ b/Calamity/Types/Model/Channel/Guild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | The generic guild channel type module Calamity.Types.Model.Channel.Guild ( GuildChannel (..), @@ -6,83 +8,53 @@ module Calamity.Types.Model.Channel.Guild.Voice, ) where -import Calamity.Internal.SnowflakeMap (SnowflakeMap) import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.ChannelType import Calamity.Types.Model.Channel.Guild.Category import Calamity.Types.Model.Channel.Guild.Text import Calamity.Types.Model.Channel.Guild.Voice import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Control.Lens -import Data.Aeson -import Data.Generics.Product.Fields -import Data.Text (Text) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import Optics ((^.)) +import Optics.TH +import TextShow.TH data GuildChannel = GuildTextChannel TextChannel | GuildVoiceChannel VoiceChannel | GuildCategory Category - deriving (Show, Eq, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric GuildChannel + | OtherGuildChannel (Snowflake Guild) (Snowflake GuildChannel) -- TODO + deriving (Show, Eq) -instance FromJSON GuildChannel where - parseJSON = withObject "GuildChannel" $ \v -> do +instance Aeson.FromJSON GuildChannel where + parseJSON = Aeson.withObject "GuildChannel" $ \v -> do type_ <- v .: "type" case type_ of - GuildTextType -> GuildTextChannel <$> parseJSON (Object v) - GuildVoiceType -> GuildVoiceChannel <$> parseJSON (Object v) - GuildCategoryType -> GuildCategory <$> parseJSON (Object v) - typ -> fail $ "Not a valid guild channel: " <> show typ + GuildTextType -> GuildTextChannel <$> Aeson.parseJSON (Aeson.Object v) + GuildVoiceType -> GuildVoiceChannel <$> Aeson.parseJSON (Aeson.Object v) + GuildCategoryType -> GuildCategory <$> Aeson.parseJSON (Aeson.Object v) + _typ -> do + id_ <- v .: "id" + guildID <- v .: "guild_id" + pure $ OtherGuildChannel guildID id_ instance HasID GuildChannel GuildChannel where - getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"id" - getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"id" - getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"id" + getID (GuildTextChannel a) = coerceSnowflake $ a ^. #id + getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. #id + getID (GuildCategory a) = coerceSnowflake $ a ^. #id + getID (OtherGuildChannel _ a) = a instance HasID Channel GuildChannel where getID = coerceSnowflake . getID @GuildChannel instance HasID Guild GuildChannel where - getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"guildID" - getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"guildID" - getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"guildID" - -instance {-# OVERLAPS #-} HasField' "name" GuildChannel Text where - field' = lens get set - where - get (GuildTextChannel (TextChannel{name})) = name - get (GuildVoiceChannel (VoiceChannel{name})) = name - get (GuildCategory (Category{name})) = name - - set (GuildTextChannel t) v = GuildTextChannel (t{name = v}) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t{name = v}) - set (GuildCategory t) v = GuildCategory (t{name = v}) - -instance {-# OVERLAPS #-} HasField' "permissionOverwrites" GuildChannel (SnowflakeMap Overwrite) where - field' = lens get set - where - get (GuildTextChannel (TextChannel{permissionOverwrites})) = permissionOverwrites - get (GuildVoiceChannel (VoiceChannel{permissionOverwrites})) = permissionOverwrites - get (GuildCategory (Category{permissionOverwrites})) = permissionOverwrites - - set (GuildTextChannel t) v = GuildTextChannel (t{permissionOverwrites = v}) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t{permissionOverwrites = v}) - set (GuildCategory t) v = GuildCategory (t{permissionOverwrites = v}) - -instance {-# OVERLAPS #-} HasField' "position" GuildChannel Int where - field' = lens get set - where - get (GuildTextChannel (TextChannel{position})) = position - get (GuildVoiceChannel (VoiceChannel{position})) = position - get (GuildCategory (Category{position})) = position + getID (GuildTextChannel a) = coerceSnowflake $ a ^. #guildID + getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. #guildID + getID (GuildCategory a) = coerceSnowflake $ a ^. #guildID + getID (OtherGuildChannel a _) = a - set (GuildTextChannel t) v = GuildTextChannel (t{position = v}) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t{position = v}) - set (GuildCategory t) v = GuildCategory (t{position = v}) +$(deriveTextShow ''GuildChannel) +$(makeFieldLabelsNoPrefix ''GuildChannel) diff --git a/Calamity/Types/Model/Channel/Guild/Category.hs b/Calamity/Types/Model/Channel/Guild/Category.hs --- a/Calamity/Types/Model/Channel/Guild/Category.hs +++ b/Calamity/Types/Model/Channel/Guild/Category.hs @@ -1,18 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + module Calamity.Types.Model.Channel.Guild.Category (Category (..)) where -import Calamity.Internal.AesonThings import Calamity.Internal.SnowflakeMap (SnowflakeMap) -import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.!=), (.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data Category = Category { id :: Snowflake Category @@ -22,9 +21,19 @@ , position :: Int , guildID :: Snowflake Guild } - deriving (Show, Eq, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric Category - deriving (ToJSON) via CalamityJSON Category - deriving (FromJSON) via WithSpecialCases '[IfNoneThen "nsfw" DefaultToFalse] Category + deriving (Show, Eq) deriving (HasID Category) via HasIDField "id" Category deriving (HasID Channel) via HasIDFieldCoerce' "id" Category + +instance Aeson.FromJSON Category where + parseJSON = Aeson.withObject "Category" $ \v -> + Category + <$> v .: "id" + <*> v .: "permission_overwrites" + <*> v .: "name" + <*> v .:? "nsfw" .!= False + <*> v .: "position" + <*> v .: "guild_id" + +$(deriveTextShow ''Category) +$(makeFieldLabelsNoPrefix ''Category) diff --git a/Calamity/Types/Model/Channel/Guild/Text.hs b/Calamity/Types/Model/Channel/Guild/Text.hs --- a/Calamity/Types/Model/Channel/Guild/Text.hs +++ b/Calamity/Types/Model/Channel/Guild/Text.hs @@ -1,39 +1,20 @@ --- | Text channels +{-# LANGUAGE TemplateHaskell #-} + module Calamity.Types.Model.Channel.Guild.Text (TextChannel (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia import Calamity.Internal.SnowflakeMap (SnowflakeMap) -import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.Guild.Category import Calamity.Types.Model.Channel.Message import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.!=), (.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Time -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data TextChannel' = TextChannel' - { id :: Snowflake TextChannel - , guildID :: Snowflake Guild - , position :: Int - , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , topic :: Maybe Text - , nsfw :: Bool - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe (CalamityFromStringShow UTCTime) - , rateLimitPerUser :: Maybe Int - , parentID :: Maybe (Snowflake Category) - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric TextChannel' +import Optics.TH +import qualified TextShow data TextChannel = TextChannel { id :: Snowflake TextChannel @@ -48,14 +29,25 @@ , rateLimitPerUser :: Maybe Int , parentID :: Maybe (Snowflake Category) } - deriving (Show, Eq, Generic, NFData) - deriving (ToJSON) via CalamityJSON TextChannel - deriving (TextShow) via OverriddenVia TextChannel TextChannel - deriving - (FromJSON) - via WithSpecialCases - '[IfNoneThen "nsfw" DefaultToFalse] - TextChannel + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow TextChannel deriving (HasID TextChannel) via HasIDField "id" TextChannel deriving (HasID Channel) via HasIDFieldCoerce' "id" TextChannel deriving (HasID Guild) via HasIDField "guildID" TextChannel + +instance Aeson.FromJSON TextChannel where + parseJSON = Aeson.withObject "TextChannel" $ \v -> + TextChannel + <$> v .: "id" + <*> v .: "guild_id" + <*> v .: "position" + <*> v .: "permission_overwrites" + <*> v .: "name" + <*> v .: "topic" + <*> v .:? "nsfw" .!= False + <*> v .:? "last_message_id" + <*> v .:? "last_pin_timestamp" + <*> v .:? "rate_limit_per_user" + <*> v .:? "parent_id" + +$(makeFieldLabelsNoPrefix ''TextChannel) diff --git a/Calamity/Types/Model/Channel/Guild/Voice.hs b/Calamity/Types/Model/Channel/Guild/Voice.hs --- a/Calamity/Types/Model/Channel/Guild/Voice.hs +++ b/Calamity/Types/Model/Channel/Guild/Voice.hs @@ -1,20 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Voice channels module Calamity.Types.Model.Channel.Guild.Voice (VoiceChannel (..)) where -import Calamity.Internal.AesonThings import Calamity.Internal.SnowflakeMap (SnowflakeMap) -import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.Guild.Category import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data VoiceChannel = VoiceChannel { id :: Snowflake VoiceChannel @@ -26,9 +25,22 @@ , userLimit :: Int , parentID :: Maybe (Snowflake Category) } - deriving (Show, Eq, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric VoiceChannel - deriving (ToJSON, FromJSON) via CalamityJSON VoiceChannel + deriving (Show, Eq) deriving (HasID VoiceChannel) via HasIDField "id" VoiceChannel deriving (HasID Channel) via HasIDFieldCoerce' "id" VoiceChannel deriving (HasID Guild) via HasIDField "guildID" VoiceChannel + +instance Aeson.FromJSON VoiceChannel where + parseJSON = Aeson.withObject "TextChannel" $ \v -> + VoiceChannel + <$> v .: "id" + <*> v .: "guild_id" + <*> v .: "position" + <*> v .: "permission_overwrites" + <*> v .: "name" + <*> v .: "bitrate" + <*> v .: "user_limit" + <*> v .:? "parent_id" + +$(deriveTextShow ''VoiceChannel) +$(makeFieldLabelsNoPrefix ''VoiceChannel) diff --git a/Calamity/Types/Model/Channel/Message.hs b/Calamity/Types/Model/Channel/Message.hs --- a/Calamity/Types/Model/Channel/Message.hs +++ b/Calamity/Types/Model/Channel/Message.hs @@ -1,16 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | A message from a channel module Calamity.Types.Model.Channel.Message ( Message (..), + MessageAuthor (..), + MessageAuthorWebhook (..), + ChannelMention (..), MessageType (..), MessageReference (..), Partial (PartialMessage), ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils +import Calamity.Internal.Utils (AesonVector (..), CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import {-# SOURCE #-} Calamity.Types.Model.Channel import Calamity.Types.Model.Channel.Attachment +import Calamity.Types.Model.Channel.ChannelType (ChannelType) import Calamity.Types.Model.Channel.Component import Calamity.Types.Model.Channel.Embed import Calamity.Types.Model.Channel.Reaction @@ -19,116 +23,169 @@ 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.Maybe (isJust) import Data.Scientific import Data.Text (Text) import Data.Time import qualified Data.Vector.Unboxing as UV import Data.Word (Word64) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import qualified TextShow +import TextShow.TH -data Message' = Message' - { id :: Snowflake Message - , channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , author :: Snowflake User - , content :: Text - , timestamp :: CalamityFromStringShow UTCTime - , editedTimestamp :: Maybe (CalamityFromStringShow UTCTime) - , tts :: Bool - , mentionEveryone :: Bool - , mentions :: AesonVector (Snowflake User) - , mentionRoles :: AesonVector (Snowflake Role) - , mentionChannels :: Maybe (AesonVector (Snowflake Channel)) - , attachments :: ![Attachment] - , embeds :: ![Embed] - , reactions :: ![Reaction] - , nonce :: Maybe (CalamityFromStringShow Value) - , pinned :: Bool - , webhookID :: Maybe (Snowflake Webhook) - , type_ :: !MessageType - , activity :: Maybe (CalamityFromStringShow Object) - , application :: Maybe (CalamityFromStringShow Object) - , messageReference :: Maybe MessageReference - , flags :: Word64 - , referencedMessage :: Maybe Message - , interaction :: Maybe (CalamityFromStringShow Object) - , components :: [Component] +data MessageAuthorWebhook = MessageAuthorWebhook + { id :: Snowflake Webhook + , username :: Text + , avatar :: Maybe Text } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric Message' - deriving - (FromJSON) - via WithSpecialCases - '[ "author" `ExtractFieldFrom` "id" - , "mentions" `ExtractArrayField` "id" - , "mention_channels" `ExtractArrayField` "id" - , "reactions" `IfNoneThen` DefaultToEmptyArray - , "components" `IfNoneThen` DefaultToEmptyArray - ] - Message' + deriving (Show) + deriving (HasID Webhook) via HasIDField "id" MessageAuthorWebhook +data MessageAuthor + = User' User + | Webhook' MessageAuthorWebhook + deriving (Show) + +instance HasID User MessageAuthor where + getID (User' u) = getID u + getID (Webhook' MessageAuthorWebhook {id}) = coerceSnowflake id + +data ChannelMention = ChannelMention + { id :: Snowflake Channel + , guildID :: Snowflake Guild + , type_ :: ChannelType + , name :: Text + } + deriving (Show) + deriving (HasID Channel) via HasIDField "id" ChannelMention + +instance Aeson.FromJSON ChannelMention where + parseJSON = Aeson.withObject "Message.ChannelMention" $ \v -> + ChannelMention + <$> v .: "id" + <*> v .: "guild_id" + <*> v .: "type" + <*> v .: "name" + data Message = Message { id :: Snowflake Message , channelID :: Snowflake Channel , guildID :: Maybe (Snowflake Guild) - , author :: Snowflake User + , author :: MessageAuthor , content :: Text , timestamp :: UTCTime , editedTimestamp :: Maybe UTCTime , tts :: Bool , mentionEveryone :: Bool - , mentions :: UV.Vector (Snowflake User) + , mentions :: [User] , mentionRoles :: UV.Vector (Snowflake Role) - , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: ![Attachment] - , embeds :: ![Embed] - , reactions :: ![Reaction] - , nonce :: Maybe Value + , mentionChannels :: [ChannelMention] + , attachments :: [Attachment] + , embeds :: [Embed] + , reactions :: [Reaction] + , nonce :: Maybe Aeson.Value , pinned :: Bool , webhookID :: Maybe (Snowflake Webhook) - , type_ :: !MessageType - , activity :: Maybe Object - , application :: Maybe Object + , type_ :: MessageType + , activity :: Maybe Aeson.Object + , application :: Maybe Aeson.Object , messageReference :: Maybe MessageReference , flags :: Word64 , referencedMessage :: Maybe Message - , interaction :: Maybe Object + , interaction :: Maybe Aeson.Object , components :: [Component] } - deriving (Show, Generic) - deriving (TextShow, FromJSON) via OverriddenVia Message Message' + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Message deriving (HasID Message) via HasIDField "id" Message deriving (HasID Channel) via HasIDField "channelID" Message deriving (HasID User) via HasIDField "author" Message +instance Aeson.FromJSON Message where + parseJSON = Aeson.withObject "Message" $ \v -> do + webhookID <- v .:? "webhook_id" + let author = + if isJust webhookID + then + Aeson.withObject + "Message.author" + ( \v -> + Webhook' + <$> ( MessageAuthorWebhook + <$> v .: "id" <*> v .: "username" <*> v .:? "avatar" + ) + ) + =<< v .: "author" + else User' <$> (Aeson.parseJSON =<< (v .: "author")) + + Message + <$> v .: "id" + <*> v .: "channel_id" + <*> v .:? "guild_id" + <*> author + <*> v .: "content" + <*> v .: "timestamp" + <*> v .:? "edited_timestamp" + <*> v .: "tts" + <*> v .: "mention_everyone" + <*> v .: "mentions" + <*> (unAesonVector <$> v .: "mention_roles") + <*> v .:? "mention_channels" .!= [] + <*> v .: "attachments" + <*> v .: "embeds" + <*> v .:? "reactions" .!= [] + <*> v .:? "nonce" + <*> v .: "pinned" + <*> pure webhookID + <*> v .: "type" + <*> v .:? "activity" + <*> v .:? "application" + <*> v .:? "message_reference" + <*> v .:? "flags" .!= 0 + <*> v .:? "referenced_message" + <*> v .:? "interaction" + <*> v .:? "components" .!= [] + data instance Partial Message = PartialMessage { channelID :: Snowflake Channel , guildID :: Maybe (Snowflake Guild) } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric (Partial Message) - deriving (FromJSON) via CalamityJSON (Partial Message) + deriving (Show) deriving (HasID Channel) via HasIDField "channelID" (Partial Message) +instance Aeson.FromJSON (Partial Message) where + parseJSON = Aeson.withObject "Partial Message" $ \v -> + PartialMessage + <$> v .: "channel_id" + <*> v .:? "guild_id" + 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 + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON MessageReference +instance CalamityToJSON' MessageReference where + toPairs MessageReference {..} = + [ "message_id" .?= messageID + , "channel_id" .?= channelID + , "guild_id" .?= guildID + , "fail_if_not_exists" .= failIfNotExists + ] + +instance Aeson.FromJSON MessageReference where + parseJSON = Aeson.withObject "MessageReference" $ \v -> + MessageReference + <$> v .:? "message_id" + <*> v .:? "channel_id" + <*> v .:? "guild_id" + <*> v .:? "fail_if_not_exists" .!= False + -- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L264) data MessageType = Default @@ -148,11 +205,10 @@ | GuildDiscoveryRequalified | Reply | ApplicationCommmand - deriving (Eq, Show, Enum, Generic) - deriving (TextShow) via TSG.FromGeneric MessageType + deriving (Eq, Show, Enum) -instance FromJSON MessageType where - parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of +instance Aeson.FromJSON MessageType where + parseJSON = Aeson.withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of Just v -> case v of 0 -> pure Default 1 -> pure RecipientAdd @@ -173,3 +229,14 @@ 20 -> pure ApplicationCommmand _ -> fail $ "Invalid MessageType: " <> show n Nothing -> fail $ "Invalid MessageType: " <> show n + +$(deriveTextShow ''MessageAuthorWebhook) +$(deriveTextShow 'PartialMessage) +$(deriveTextShow ''ChannelMention) +$(deriveTextShow ''MessageType) + +$(makeFieldLabelsNoPrefix ''MessageAuthorWebhook) +$(makeFieldLabelsNoPrefix ''ChannelMention) +$(makeFieldLabelsNoPrefix 'PartialMessage) +$(makeFieldLabelsNoPrefix ''Message) +$(makeFieldLabelsNoPrefix ''MessageReference) diff --git a/Calamity/Types/Model/Channel/Reaction.hs b/Calamity/Types/Model/Channel/Reaction.hs --- a/Calamity/Types/Model/Channel/Reaction.hs +++ b/Calamity/Types/Model/Channel/Reaction.hs @@ -1,21 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Message reactions module Calamity.Types.Model.Channel.Reaction (Reaction (..)) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (toPairs), (.=)) import Calamity.Types.Model.Guild.Emoji - -import Data.Aeson - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import Optics.TH +import TextShow.TH data Reaction = Reaction { count :: Integer , me :: Bool , emoji :: RawEmoji } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric Reaction - deriving (ToJSON, FromJSON) via CalamityJSON Reaction + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON Reaction + +instance CalamityToJSON' Reaction where + toPairs Reaction {..} = + [ "count" .= count + , "me" .= me + , "emoj" .= emoji + ] + +instance Aeson.FromJSON Reaction where + parseJSON = Aeson.withObject "Reaction" $ \v -> + Reaction + <$> v .: "count" + <*> v .: "me" + <*> v .: "emoji" + +$(deriveTextShow ''Reaction) +$(makeFieldLabelsNoPrefix ''Reaction) diff --git a/Calamity/Types/Model/Channel/UpdatedMessage.hs b/Calamity/Types/Model/Channel/UpdatedMessage.hs --- a/Calamity/Types/Model/Channel/UpdatedMessage.hs +++ b/Calamity/Types/Model/Channel/UpdatedMessage.hs @@ -1,84 +1,75 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Updated messages module Calamity.Types.Model.Channel.UpdatedMessage ( - UpdatedMessage (..), + UpdatedMessage (..), ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia import Calamity.Internal.Utils import Calamity.Types.Model.Channel 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.Text (Text) import Data.Time import qualified Data.Vector.Unboxing as UV import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data UpdatedMessage' = UpdatedMessage' - { id :: Snowflake Message - , channelID :: Snowflake Channel - , content :: Maybe Text - , editedTimestamp :: Maybe (MaybeNull (CalamityFromStringShow UTCTime)) - , tts :: Maybe Bool - , mentionEveryone :: Maybe Bool - , mentions :: Maybe (AesonVector (Snowflake User)) - , mentionRoles :: Maybe (AesonVector (Snowflake Role)) - , mentionChannels :: Maybe (AesonVector (Snowflake Channel)) - , attachments :: !(Maybe [Attachment]) - , embeds :: Maybe [Embed] - , reactions :: Maybe [Reaction] - , pinned :: Maybe Bool - , webhookID :: Maybe (MaybeNull (Snowflake Webhook)) - , type_ :: Maybe MessageType - , activity :: Maybe (MaybeNull (CalamityFromStringShow Object)) - , application :: Maybe (MaybeNull (CalamityFromStringShow Object)) - , messageReference :: Maybe (MaybeNull MessageReference) - , flags :: Maybe Word64 - , referencedMessage :: Maybe (MaybeNull Message) - , interaction :: Maybe (MaybeNull (CalamityFromStringShow Object)) - , components :: Maybe [Component] - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric UpdatedMessage' - deriving - (FromJSON) - via WithSpecialCases - '[ "author" `ExtractFieldFrom` "id" - , "mentions" `ExtractArrayField` "id" - , "mention_channels" `ExtractArrayField` "id" - ] - UpdatedMessage' +import Optics.TH +import qualified TextShow data UpdatedMessage = UpdatedMessage - { id :: Snowflake Message - , channelID :: Snowflake Channel - , content :: Maybe Text - , editedTimestamp :: Maybe (MaybeNull UTCTime) - , tts :: Maybe Bool - , mentionEveryone :: Maybe Bool - , mentions :: Maybe (UV.Vector (Snowflake User)) - , mentionRoles :: Maybe (UV.Vector (Snowflake Role)) - , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: !(Maybe [Attachment]) - , embeds :: Maybe [Embed] - , reactions :: Maybe [Reaction] - , pinned :: Maybe Bool - , webhookID :: Maybe (MaybeNull (Snowflake Webhook)) - , type_ :: Maybe MessageType - , activity :: Maybe (MaybeNull Object) - , application :: Maybe (MaybeNull Object) - , messageReference :: Maybe (MaybeNull MessageReference) - , flags :: Maybe Word64 - , referencedMessage :: Maybe (MaybeNull Message) - , interaction :: Maybe (MaybeNull Object) - , components :: Maybe [Component] - } - deriving (Show, Generic) - deriving (TextShow, FromJSON) via OverriddenVia UpdatedMessage UpdatedMessage' - deriving (HasID Message) via HasIDField "id" UpdatedMessage - deriving (HasID Channel) via HasIDField "channelID" UpdatedMessage + { id :: Snowflake Message + , channelID :: Snowflake Channel + , content :: Maybe Text + , editedTimestamp :: Maybe (MaybeNull UTCTime) + , tts :: Maybe Bool + , mentionEveryone :: Maybe Bool + , mentions :: Maybe [User] + , mentionRoles :: Maybe (UV.Vector (Snowflake Role)) + , mentionChannels :: Maybe [ChannelMention] + , attachments :: Maybe [Attachment] + , embeds :: Maybe [Embed] + , reactions :: Maybe [Reaction] + , pinned :: Maybe Bool + , type_ :: Maybe MessageType + , activity :: Maybe (MaybeNull Aeson.Object) + , application :: Maybe (MaybeNull Aeson.Object) + , messageReference :: Maybe (MaybeNull MessageReference) + , flags :: Maybe Word64 + , referencedMessage :: Maybe (MaybeNull Message) + , interaction :: Maybe (MaybeNull Aeson.Object) + , components :: Maybe [Component] + } + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow UpdatedMessage + deriving (HasID Message) via HasIDField "id" UpdatedMessage + deriving (HasID Channel) via HasIDField "channelID" UpdatedMessage + +instance Aeson.FromJSON UpdatedMessage where + parseJSON = Aeson.withObject "UpdatedMessage" $ \v -> + UpdatedMessage + <$> v .: "id" + <*> v .: "channel_id" + <*> v .:? "content" + <*> v .:! "edited_timestamp" + <*> v .:? "tts" + <*> v .:? "mention_everyone" + <*> v .:? "mentions" + <*> (fmap unAesonVector <$> v .:? "mention_roles") + <*> v .:? "mention_channels" + <*> v .:? "attachments" + <*> v .:? "embeds" + <*> v .:? "reactions" + <*> v .:? "pinned" + <*> v .:? "type" + <*> v .:! "activity" + <*> v .:! "application" + <*> v .:! "message_reference" + <*> v .:? "flags" + <*> v .:! "referenced_message" + <*> v .:! "interaction" + <*> v .:? "components" + +$(makeFieldLabelsNoPrefix ''UpdatedMessage) diff --git a/Calamity/Types/Model/Channel/Webhook.hs b/Calamity/Types/Model/Channel/Webhook.hs --- a/Calamity/Types/Model/Channel/Webhook.hs +++ b/Calamity/Types/Model/Channel/Webhook.hs @@ -1,19 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Channel webhooks module Calamity.Types.Model.Channel.Webhook (Webhook (..)) where -import Calamity.Internal.AesonThings import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake - -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data Webhook = Webhook { id :: Snowflake Webhook @@ -25,7 +23,23 @@ , avatar :: Text , token :: Maybe Text } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric Webhook - deriving (FromJSON) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Webhook + deriving (Eq, Show) deriving (HasID Webhook) via HasIDField "id" Webhook + +instance Aeson.FromJSON Webhook where + parseJSON = Aeson.withObject "Webhook" $ \v -> do + user <- v .:? "user" + userID <- traverse (.: "id") user + + Webhook + <$> v .: "id" + <*> v .: "type" + <*> v .:? "guild_id" + <*> v .:? "channel_id" + <*> pure userID + <*> v .: "name" + <*> v .: "avatar" + <*> v .:? "token" + +$(deriveTextShow ''Webhook) +$(makeFieldLabelsNoPrefix ''Webhook) diff --git a/Calamity/Types/Model/Guild.hs b/Calamity/Types/Model/Guild.hs --- a/Calamity/Types/Model/Guild.hs +++ b/Calamity/Types/Model/Guild.hs @@ -1,23 +1,24 @@ -- | Discord Guilds -module Calamity.Types.Model.Guild - ( module Calamity.Types.Model.Guild.AuditLog - , module Calamity.Types.Model.Guild.Ban - , module Calamity.Types.Model.Guild.Emoji - , module Calamity.Types.Model.Guild.Guild - , module Calamity.Types.Model.Guild.Member - , module Calamity.Types.Model.Guild.Overwrite - , module Calamity.Types.Model.Guild.Invite - , module Calamity.Types.Model.Guild.Role - , module Calamity.Types.Model.Guild.UnavailableGuild - , module Calamity.Types.Model.Guild.Permissions ) where +module Calamity.Types.Model.Guild ( + module Calamity.Types.Model.Guild.AuditLog, + module Calamity.Types.Model.Guild.Ban, + module Calamity.Types.Model.Guild.Emoji, + module Calamity.Types.Model.Guild.Guild, + module Calamity.Types.Model.Guild.Member, + module Calamity.Types.Model.Guild.Overwrite, + module Calamity.Types.Model.Guild.Invite, + module Calamity.Types.Model.Guild.Role, + module Calamity.Types.Model.Guild.UnavailableGuild, + module Calamity.Types.Model.Guild.Permissions, +) where -import Calamity.Types.Model.Guild.AuditLog -import Calamity.Types.Model.Guild.Ban -import Calamity.Types.Model.Guild.Emoji -import Calamity.Types.Model.Guild.Guild hiding ( UpdatedGuild(..) ) -import Calamity.Types.Model.Guild.Invite -import Calamity.Types.Model.Guild.Member -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.Guild.UnavailableGuild -import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Model.Guild.AuditLog +import Calamity.Types.Model.Guild.Ban +import Calamity.Types.Model.Guild.Emoji +import Calamity.Types.Model.Guild.Guild hiding (UpdatedGuild (..)) +import Calamity.Types.Model.Guild.Invite +import Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.Guild.UnavailableGuild diff --git a/Calamity/Types/Model/Guild/AuditLog.hs b/Calamity/Types/Model/Guild/AuditLog.hs --- a/Calamity/Types/Model/Guild/AuditLog.hs +++ b/Calamity/Types/Model/Guild/AuditLog.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Audit Log models module Calamity.Types.Model.Guild.AuditLog ( AuditLog (..), @@ -7,45 +9,49 @@ AuditLogAction (..), ) where -import Calamity.Internal.AesonThings import Calamity.Internal.SnowflakeMap (SnowflakeMap) import Calamity.Types.Model.Channel import Calamity.Types.Model.User import Calamity.Types.Snowflake - -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Scientific import Data.Text (Text) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import qualified TextShow +import TextShow.TH data AuditLog = AuditLog { webhooks :: SnowflakeMap Webhook , users :: SnowflakeMap User , auditLogEntries :: SnowflakeMap AuditLogEntry } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric AuditLog - deriving (FromJSON) via CalamityJSON AuditLog + deriving (Show) data AuditLogEntry = AuditLogEntry { targetID :: Maybe (Snowflake ()) , changes :: [AuditLogChange] , userID :: Snowflake User , id :: Snowflake AuditLogEntry - , actionType :: !AuditLogAction + , actionType :: AuditLogAction , options :: Maybe AuditLogEntryInfo , reason :: Maybe Text } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric AuditLogEntry - deriving (FromJSON) via CalamityJSON AuditLogEntry + deriving (Show) deriving (HasID User) via HasIDField "userID" AuditLogEntry deriving (HasID AuditLogEntry) via HasIDField "id" AuditLogEntry +instance Aeson.FromJSON AuditLogEntry where + parseJSON = Aeson.withObject "AuditLogEntry" $ \v -> + AuditLogEntry + <$> v .:? "target_id" + <*> v .: "changes" + <*> v .: "user_id" + <*> v .: "id" + <*> v .: "action_type" + <*> v .: "options" + <*> v .:? "reason" + data AuditLogEntryInfo = AuditLogEntryInfo { deleteMemberDays :: Maybe Text , membersRemoved :: Maybe Text @@ -56,19 +62,35 @@ , type_ :: Maybe Text , roleName :: Maybe Text } - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric AuditLogEntryInfo - deriving (FromJSON) via CalamityJSON AuditLogEntryInfo + deriving (Show) +instance Aeson.FromJSON AuditLogEntryInfo where + parseJSON = Aeson.withObject "AudotLogEntryInfo" $ \v -> + AuditLogEntryInfo + <$> v .:? "delete_member_days" + <*> v .:? "members_removed" + <*> v .:? "channel_id" + <*> v .:? "message_id" + <*> v .:? "count" + <*> v .:? "id" + <*> v .:? "type" + <*> v .:? "role_name" + data AuditLogChange = AuditLogChange - { newValue :: Maybe Value - , oldValue :: Maybe Value + { newValue :: Maybe Aeson.Value + , oldValue :: Maybe Aeson.Value , key :: Text } - deriving (Show, Generic) - deriving (TextShow) via FromStringShow AuditLogChange - deriving (FromJSON) via CalamityJSON AuditLogChange + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow AuditLogChange +instance Aeson.FromJSON AuditLogChange where + parseJSON = Aeson.withObject "AudotLogChange" $ \v -> + AuditLogChange + <$> v .:? "new_value" + <*> v .:? "old_value" + <*> v .: "key" + data AuditLogAction = GUILD_UPDATE | CHANNEL_CREATE @@ -105,8 +127,7 @@ | INTEGRATION_CREATE | INTEGRATION_UPDATE | INTEGRATION_DELETE - deriving (Show, Generic) - deriving (TextShow) via TSG.FromGeneric AuditLogAction + deriving (Show) instance Enum AuditLogAction where toEnum v = case v of @@ -184,8 +205,8 @@ INTEGRATION_UPDATE -> 81 INTEGRATION_DELETE -> 82 -instance FromJSON AuditLogAction where - parseJSON = withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of +instance Aeson.FromJSON AuditLogAction where + parseJSON = Aeson.withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of Just v -> case v of -- no safe toEnum :S 1 -> pure GUILD_UPDATE 10 -> pure CHANNEL_CREATE @@ -225,5 +246,16 @@ _ -> fail $ "Invalid AuditLogAction: " <> show n Nothing -> fail $ "Invalid AuditLogAction: " <> show n -instance ToJSON AuditLogAction where - toJSON = toJSON @Int . fromEnum +instance Aeson.ToJSON AuditLogAction where + toJSON = Aeson.toJSON @Int . fromEnum + toEncoding = Aeson.toEncoding @Int . fromEnum + +$(deriveTextShow ''AuditLogAction) +$(deriveTextShow ''AuditLogEntryInfo) +$(deriveTextShow ''AuditLogEntry) +$(deriveTextShow ''AuditLog) + +$(makeFieldLabelsNoPrefix ''AuditLog) +$(makeFieldLabelsNoPrefix ''AuditLogEntry) +$(makeFieldLabelsNoPrefix ''AuditLogEntryInfo) +$(makeFieldLabelsNoPrefix ''AuditLogChange) diff --git a/Calamity/Types/Model/Guild/Ban.hs b/Calamity/Types/Model/Guild/Ban.hs --- a/Calamity/Types/Model/Guild/Ban.hs +++ b/Calamity/Types/Model/Guild/Ban.hs @@ -1,26 +1,29 @@ --- | Guild ban objects -module Calamity.Types.Model.Guild.Ban - ( BanData(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson +{-# LANGUAGE TemplateHaskell #-} -import GHC.Generics +-- | Guild ban objects +module Calamity.Types.Model.Guild.Ban (BanData (..)) where -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import Optics.TH +import TextShow.TH data BanData = BanData { guildID :: Snowflake Guild - , user :: User + , user :: User } - deriving ( Show, Generic ) - deriving ( FromJSON ) via CalamityJSON BanData - deriving ( TextShow ) via TSG.FromGeneric BanData - deriving ( HasID Guild ) via HasIDField "guildID" BanData - deriving ( HasID User ) via HasIDField "user" BanData + deriving (Show) + deriving (HasID Guild) via HasIDField "guildID" BanData + deriving (HasID User) via HasIDField "user" BanData + +instance Aeson.FromJSON BanData where + parseJSON = Aeson.withObject "BanData" $ \v -> + BanData + <$> v .: "guild_id" + <*> v .: "user" + +$(deriveTextShow ''BanData) +$(makeFieldLabelsNoPrefix ''BanData) diff --git a/Calamity/Types/Model/Guild/Emoji.hs b/Calamity/Types/Model/Guild/Emoji.hs --- a/Calamity/Types/Model/Guild/Emoji.hs +++ b/Calamity/Types/Model/Guild/Emoji.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Discord emojis module Calamity.Types.Model.Guild.Emoji ( Emoji (..), @@ -6,102 +8,105 @@ emojiAsRawEmoji, ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils +import Calamity.Internal.Utils ( + AesonVector (unAesonVector), + CalamityToJSON (..), + CalamityToJSON' (..), + (.=), + ) import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson -import Data.Generics.Product +import Data.Aeson ((.!=), (.:), (.:?)) +import qualified Data.Aeson as Aeson import qualified Data.Text as T import Data.Vector.Unboxing (Vector) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data Emoji' = Emoji' - { id :: Snowflake Emoji - , name :: T.Text - , roles :: AesonVector (Snowflake Role) - , user :: Maybe (Snowflake User) - , requireColons :: Bool - , managed :: Bool - , animated :: Bool - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric Emoji' - deriving (ToJSON) via CalamityJSON Emoji' - deriving - (FromJSON) - via WithSpecialCases - '[ "user" `ExtractFieldFrom` "id" - , "roles" `IfNoneThen` DefaultToEmptyArray - ] - Emoji' +import Optics.TH +import qualified TextShow data Emoji = Emoji { id :: Snowflake Emoji , name :: T.Text , roles :: Vector (Snowflake Role) - , user :: Maybe (Snowflake User) + , user :: Maybe User , requireColons :: Bool , managed :: Bool , animated :: Bool } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow, ToJSON, FromJSON) via OverriddenVia Emoji Emoji' + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Emoji deriving (HasID Emoji) via HasIDField "id" Emoji +instance Aeson.FromJSON Emoji where + parseJSON = Aeson.withObject "Emoji" $ \v -> + Emoji + <$> v .: "id" + <*> v .: "name" + <*> (fmap unAesonVector <$> v .:? "roles") .!= mempty + <*> v .:? "user" + <*> v .:? "require_colons" .!= False + <*> v .:? "managed" .!= False + <*> v .:? "animated" .!= False + emojiAsRawEmoji :: Emoji -> RawEmoji -emojiAsRawEmoji = CustomEmoji . upcast +emojiAsRawEmoji Emoji {id, name, animated} = CustomEmoji $ PartialEmoji id name animated data instance Partial Emoji = PartialEmoji { id :: Snowflake Emoji , name :: T.Text , animated :: Bool } - deriving (Eq, Generic) - deriving (ToJSON) via CalamityJSON (Partial Emoji) - deriving - (FromJSON) - via WithSpecialCases - '["animated" `IfNoneThen` DefaultToFalse] - (Partial Emoji) + deriving (Eq) deriving (HasID Emoji) via HasIDField "id" (Partial Emoji) + deriving (Aeson.ToJSON) via CalamityToJSON (Partial Emoji) +instance Aeson.FromJSON (Partial Emoji) where + parseJSON = Aeson.withObject "Partial Emoji" $ \v -> + PartialEmoji + <$> v .: "id" + <*> v .: "name" + <*> v .:? "animated" .!= False + +instance CalamityToJSON' (Partial Emoji) where + toPairs PartialEmoji {..} = + [ "id" .= id + , "name" .= name + , "animated" .= animated + ] + instance Show (Partial Emoji) where - show PartialEmoji{id, name, animated} = + show PartialEmoji {id, name, animated} = "<" <> a <> ":" <> T.unpack name <> ":" <> show id <> ">" - where - a = if animated then "a" else "" + where + a = if animated then "a" else "" -instance TextShow (Partial Emoji) where - showb PartialEmoji{id, name, animated} = - "<" <> a <> ":" <> fromText name <> ":" <> showb id <> ">" - where - a = if animated then "a" else "" +instance TextShow.TextShow (Partial Emoji) where + showb PartialEmoji {id, name, animated} = + "<" <> a <> ":" <> TextShow.fromText name <> ":" <> TextShow.showb id <> ">" + where + a = if animated then "a" else "" data RawEmoji = UnicodeEmoji T.Text | CustomEmoji (Partial Emoji) - deriving (Eq, Generic) + deriving (Eq) instance Show RawEmoji where show (UnicodeEmoji v) = T.unpack v show (CustomEmoji p) = show p -instance TextShow RawEmoji where - showb (UnicodeEmoji v) = fromText v - showb (CustomEmoji p) = showb p +instance TextShow.TextShow RawEmoji where + showb (UnicodeEmoji v) = TextShow.fromText v + showb (CustomEmoji p) = TextShow.showb p -instance ToJSON RawEmoji where - toJSON (CustomEmoji e) = toJSON e - toJSON (UnicodeEmoji s) = object ["name" .= s, "id" .= Nothing @()] +instance Aeson.ToJSON RawEmoji where + toJSON (CustomEmoji e) = Aeson.toJSON e + toJSON (UnicodeEmoji s) = Aeson.object ["name" Aeson..= s, "id" Aeson..= Nothing @()] + toEncoding (CustomEmoji e) = Aeson.toEncoding e + toEncoding (UnicodeEmoji s) = Aeson.pairs . mconcat $ ["name" Aeson..= s, "id" Aeson..= Nothing @()] -instance FromJSON RawEmoji where - parseJSON = withObject "RawEmoji" $ \v -> do +instance Aeson.FromJSON RawEmoji where + parseJSON = Aeson.withObject "RawEmoji" $ \v -> do m_id :: Maybe (Snowflake Emoji) <- v .:? "id" anim <- v .:? "animated" .!= False name :: T.Text <- v .: "name" @@ -109,3 +114,7 @@ pure $ case m_id of Just id -> CustomEmoji $ PartialEmoji id name anim Nothing -> UnicodeEmoji name + +$(makeFieldLabelsNoPrefix ''Emoji) +$(makeFieldLabelsNoPrefix 'PartialEmoji) +$(makeFieldLabelsNoPrefix ''RawEmoji) diff --git a/Calamity/Types/Model/Guild/Guild.hs b/Calamity/Types/Model/Guild/Guild.hs --- a/Calamity/Types/Model/Guild/Guild.hs +++ b/Calamity/Types/Model/Guild/Guild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Discord Guilds module Calamity.Types.Model.Guild.Guild ( Guild (..), @@ -5,11 +7,9 @@ UpdatedGuild (..), ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia import Calamity.Internal.SnowflakeMap (SnowflakeMap) import qualified Calamity.Internal.SnowflakeMap as SM -import Calamity.Internal.Utils +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Emoji import Calamity.Types.Model.Guild.Member @@ -18,57 +18,18 @@ import Calamity.Types.Model.User import Calamity.Types.Model.Voice.VoiceState import Calamity.Types.Snowflake -import Control.DeepSeq -import Control.Lens ((^.)) -import Data.Aeson -import Data.Aeson.Types -import Data.Generics.Product.Fields +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 Data.Time import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data Guild' = Guild' - { id :: Snowflake Guild - , name :: Text - , icon :: Maybe Text - , splash :: Maybe Text - , owner :: Maybe Bool - , ownerID :: Snowflake User - , permissions :: Word64 - , region :: Text - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Int - , embedEnabled :: Bool - , embedChannelID :: Maybe (Snowflake GuildChannel) - , verificationLevel :: Int - , defaultMessageNotifications :: Int - , explicitContentFilter :: Int - , roles :: SnowflakeMap Role - , emojis :: SnowflakeMap Emoji - , features :: [Text] - , mfaLevel :: Int - , applicationID :: Maybe (Snowflake User) - , widgetEnabled :: Bool - , widgetChannelID :: Maybe (Snowflake GuildChannel) - , systemChannelID :: Maybe (Snowflake GuildChannel) - , -- NOTE: Below are only sent on GuildCreate - joinedAt :: Maybe (CalamityFromStringShow UTCTime) - , large :: Bool - , unavailable :: Bool - , memberCount :: Int - , voiceStates :: [VoiceState] - , members :: SnowflakeMap Member - , channels :: SnowflakeMap GuildChannel - , presences :: CalamityFromStringShow (HashMap (Snowflake User) Presence) - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric Guild' +import Optics +import qualified TextShow +import TextShow.TH (deriveTextShow) data Guild = Guild { id :: Snowflake Guild @@ -78,7 +39,6 @@ , owner :: Maybe Bool , ownerID :: Snowflake User , permissions :: Word64 - , region :: Text , afkChannelID :: Maybe (Snowflake GuildChannel) , afkTimeout :: Int , embedEnabled :: Bool @@ -103,32 +63,32 @@ , members :: SnowflakeMap Member , channels :: SnowflakeMap GuildChannel , presences :: HashMap (Snowflake User) Presence + , preferredLocale :: Text } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via OverriddenVia Guild Guild' + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Guild deriving (HasID Guild) via HasIDField "id" Guild -instance FromJSON Guild where - parseJSON = withObject "Guild" $ \v -> do +instance Aeson.FromJSON Guild where + parseJSON = Aeson.withObject "Guild" $ \v -> do id <- v .: "id" members' <- do members' <- v .: "members" - pure . SM.fromList . mapMaybe (parseMaybe @Object @Member (parseJSON . Object)) $ members' + pure . SM.fromList . mapMaybe (Aeson.parseMaybe @Aeson.Object @Member (Aeson.parseJSON . Aeson.Object)) $ members' - -- sadly we have now way of logging channels/presences' that failed to parse here channels' <- do channels' <- v .: "channels" - pure . SM.fromList . mapMaybe (parseMaybe @Object @GuildChannel (\c -> parseJSON $ Object (c <> "guild_id" .= id))) $ channels' + SM.fromList <$> traverse (\c -> Aeson.parseJSON $ Aeson.Object (c <> "guild_id" Aeson..= id)) channels' presences' <- do presences' <- v .: "presences" pure . LH.fromList . mapMaybe - ( parseMaybe @Object @(Snowflake User, Presence) + ( Aeson.parseMaybe @Aeson.Object @(Snowflake User, Presence) ( \m -> do - p <- parseJSON $ Object (m <> "guild_id" .= id) - pure (getID $ p ^. field @"user", p) + p <- Aeson.parseJSON $ Aeson.Object (m <> "guild_id" Aeson..= id) + pure (getID $ p ^. labelOptic @"user", p) ) ) $ presences' @@ -140,7 +100,6 @@ <*> v .:? "owner" <*> v .: "owner_id" <*> v .:? "permissions" .!= 0 - <*> v .: "region" <*> v .:? "afk_channel_id" <*> v .: "afk_timeout" <*> v .:? "embed_enabled" .!= False @@ -164,16 +123,28 @@ <*> pure members' <*> pure channels' <*> pure presences' + <*> v .: "preferred_locale" data instance Partial Guild = PartialGuild { id :: Snowflake Guild , name :: Text } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric (Partial Guild) - deriving (ToJSON, FromJSON) via CalamityJSON (Partial Guild) + deriving (Eq, Show) deriving (HasID Guild) via HasIDField "id" (Partial Guild) + deriving (Aeson.ToJSON) via CalamityToJSON (Partial Guild) +instance CalamityToJSON' (Partial Guild) where + toPairs PartialGuild {..} = + [ "id" .= id + , "name" .= name + ] + +instance Aeson.FromJSON (Partial Guild) where + parseJSON = Aeson.withObject "Partial Guild" $ \v -> + PartialGuild + <$> v .: "id" + <*> v .: "name" + data UpdatedGuild = UpdatedGuild { id :: Snowflake Guild , name :: Text @@ -182,7 +153,6 @@ , owner :: Maybe Bool , ownerID :: Snowflake User , permissions :: Maybe Word64 - , region :: Text , afkChannelID :: Maybe (Snowflake GuildChannel) , afkTimeout :: Int , embedEnabled :: Maybe Bool @@ -198,8 +168,41 @@ , widgetEnabled :: Maybe Bool , widgetChannelID :: Maybe (Snowflake GuildChannel) , systemChannelID :: Maybe (Snowflake GuildChannel) + , preferredLocale :: Text } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric UpdatedGuild - deriving (FromJSON) via CalamityJSON UpdatedGuild + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow UpdatedGuild deriving (HasID Guild) via HasIDField "id" UpdatedGuild + +instance Aeson.FromJSON UpdatedGuild where + parseJSON = Aeson.withObject "Guild" $ \v -> do + UpdatedGuild + <$> v .: "id" + <*> v .: "name" + <*> v .:? "icon" + <*> v .:? "splash" + <*> v .:? "owner" + <*> v .: "owner_id" + <*> v .:? "permissions" + <*> v .:? "afk_channel_id" + <*> v .: "afk_timeout" + <*> v .:? "embed_enabled" + <*> v .:? "embed_channel_id" + <*> v .: "verification_level" + <*> v .: "default_message_notifications" + <*> v .: "explicit_content_filter" + <*> v .: "roles" + <*> v .: "emojis" + <*> v .: "features" + <*> v .: "mfa_level" + <*> v .:? "application_id" + <*> v .:? "widget_enabled" + <*> v .:? "widget_channel_id" + <*> v .:? "system_channel_id" + <*> v .: "preferred_locale" + +$(deriveTextShow 'PartialGuild) + +$(makeFieldLabelsNoPrefix ''Guild) +$(makeFieldLabelsNoPrefix 'PartialGuild) +$(makeFieldLabelsNoPrefix ''UpdatedGuild) diff --git a/Calamity/Types/Model/Guild/Invite.hs b/Calamity/Types/Model/Guild/Invite.hs --- a/Calamity/Types/Model/Guild/Invite.hs +++ b/Calamity/Types/Model/Guild/Invite.hs @@ -1,30 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Guild invites module Calamity.Types.Model.Guild.Invite (Invite (..)) where -import Calamity.Internal.AesonThings import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Data.Time (UTCTime) +import Optics.TH +import qualified TextShow data Invite = Invite { code :: Text , guild :: Maybe (Partial Guild) , channel :: Maybe (Partial Channel) - , targetUser :: Maybe (Snowflake User) - , targetUserType :: Maybe Int + , inviter :: Maybe User + , targetUser :: Maybe User + , targetType :: Maybe Int , approximatePresenceCount :: Maybe Int , approximateMemberCount :: Maybe Int + , expiresAt :: Maybe UTCTime } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric Invite - deriving (ToJSON) via CalamityJSON Invite - deriving (FromJSON) via WithSpecialCases '["targetUser" `ExtractFieldFrom` "id"] Invite + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Invite + +instance Aeson.FromJSON Invite where + parseJSON = Aeson.withObject "Invite" $ \v -> + Invite + <$> v .: "code" + <*> v .:? "guild" + <*> v .:? "channel" + <*> v .:? "inviter" + <*> v .:? "target_user" + <*> v .:? "target_type" + <*> v .:? "approximate_presence_count" + <*> v .:? "approximate_user_count" + <*> v .:? "expires_at" + +$(makeFieldLabelsNoPrefix ''Invite) diff --git a/Calamity/Types/Model/Guild/Member.hs b/Calamity/Types/Model/Guild/Member.hs --- a/Calamity/Types/Model/Guild/Member.hs +++ b/Calamity/Types/Model/Guild/Member.hs @@ -1,58 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Guild Members module Calamity.Types.Model.Guild.Member (Member (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils +import Calamity.Internal.Utils (AesonVector (unAesonVector)) import Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.:), (.:?), (.!=)) +import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Time import Data.Vector.Unboxing (Vector) +import qualified Data.Vector.Unboxing as V import Data.Word (Word64) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data Member' = Member' - { 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 - , nick :: Maybe Text - , roles :: AesonVector (Snowflake Role) - , joinedAt :: CalamityFromStringShow UTCTime - , deaf :: Bool - , mute :: Bool - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric Member' - deriving - (FromJSON) - via WithSpecialCases - '[ "user" - `ExtractFields` [ "id" - , "username" - , "discriminator" - , "bot" - , "avatar" - , "mfa_enabled" - , "verified" - , "email" - , "flags" - , "premium_type" - ] - ] - Member' +import Optics.TH +import qualified TextShow data Member = Member { id :: Snowflake User @@ -71,7 +34,30 @@ , deaf :: Bool , mute :: Bool } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow, FromJSON) via OverriddenVia Member Member' + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Member deriving (HasID Member) via HasIDFieldCoerce "id" Member User deriving (HasID User) via HasIDField "id" Member + +instance Aeson.FromJSON Member where + parseJSON = Aeson.withObject "Member" $ \v -> do + u :: Aeson.Object <- v .: "user" + + Member + <$> u .: "id" + <*> u .: "username" + <*> u .: "discriminator" + <*> v .:? "bot" + <*> v .:? "avatar" + <*> v .:? "mfa_enabled" + <*> v .:? "verified" + <*> v .:? "email" + <*> v .:? "flags" + <*> v .:? "premium_type" + <*> v .:? "nick" + <*> (fmap unAesonVector <$> v .:? "roles") .!= V.empty + <*> v .: "joined_at" + <*> v .: "deaf" + <*> v .: "mute" + +$(makeFieldLabelsNoPrefix ''Member) diff --git a/Calamity/Types/Model/Guild/Overwrite.hs b/Calamity/Types/Model/Guild/Overwrite.hs --- a/Calamity/Types/Model/Guild/Overwrite.hs +++ b/Calamity/Types/Model/Guild/Overwrite.hs @@ -1,17 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Permission overwrites module Calamity.Types.Model.Guild.Overwrite (Overwrite (..)) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake - -import Data.Aeson - -import GHC.Generics - -import Control.DeepSeq (NFData) -import TextShow -import qualified TextShow.Generic as TSG +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import Optics.TH +import TextShow.TH data Overwrite = Overwrite { id :: Snowflake Overwrite @@ -19,7 +17,25 @@ , allow :: Permissions , deny :: Permissions } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric Overwrite - deriving (ToJSON, FromJSON) via CalamityJSON Overwrite + deriving (Eq, Show) deriving (HasID Overwrite) via HasIDField "id" Overwrite + deriving (Aeson.ToJSON) via CalamityToJSON Overwrite + +instance CalamityToJSON' Overwrite where + toPairs Overwrite {..} = + [ "id" .= id + , "type" .= type_ + , "allow" .= allow + , "deny" .= deny + ] + +instance Aeson.FromJSON Overwrite where + parseJSON = Aeson.withObject "Overwrite" $ \v -> + Overwrite + <$> v .: "id" + <*> v .: "type" + <*> v .: "allow" + <*> v .: "deny" + +$(deriveTextShow ''Overwrite) +$(makeFieldLabelsNoPrefix ''Overwrite) diff --git a/Calamity/Types/Model/Guild/Permissions.hs b/Calamity/Types/Model/Guild/Permissions.hs --- a/Calamity/Types/Model/Guild/Permissions.hs +++ b/Calamity/Types/Model/Guild/Permissions.hs @@ -2,87 +2,97 @@ {-# LANGUAGE NoDeriveAnyClass #-} -- | Guild permissions -module Calamity.Types.Model.Guild.Permissions - ( Permissions (..), - createInstantInvite, - kickMembers, - banMembers, - administrator, - manageChannels, - manageGuild, - addReactions, - viewAuditLog, - prioritySpeaker, - stream, - viewChannel, - sendMessages, - sendTtsMessages, - manageMessages, - embedLinks, - attachFiles, - readMessageHistory, - mentionEveryone, - useExternalEmojis, - viewGuildInsights, - connect, - speak, - muteMembers, - deafenMembers, - moveMembers, - useVad, - changeNickname, - manageNicknames, - manageRoles, - manageWebhooks, - manageEmojis, - ) -where +module Calamity.Types.Model.Guild.Permissions ( + Permissions (..), + createInstantInvite, + kickMembers, + banMembers, + administrator, + manageChannels, + manageGuild, + addReactions, + viewAuditLog, + prioritySpeaker, + stream, + viewChannel, + sendMessages, + sendTtsMessages, + manageMessages, + embedLinks, + attachFiles, + readMessageHistory, + mentionEveryone, + useExternalEmojis, + viewGuildInsights, + connect, + speak, + muteMembers, + deafenMembers, + moveMembers, + useVad, + changeNickname, + manageNicknames, + manageRoles, + manageWebhooks, + manageEmojis, +) where +import Control.DeepSeq (NFData) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson.Types (parseFail) +import Data.Bits (Bits (shiftL)) import Data.Flags () import Data.Flags.TH import Data.Text.Read (decimal) import Data.Word import TextShow -import Control.DeepSeq (NFData) $( bitmaskWrapper - "Permissions" - ''Word64 - [] - [ ("createInstantInvite", 0x00000001), - ("kickMembers", 0x00000002), - ("banMembers", 0x00000004), - ("administrator", 0x00000008), - ("manageChannels", 0x00000010), - ("manageGuild", 0x00000020), - ("addReactions", 0x00000040), - ("viewAuditLog", 0x00000080), - ("prioritySpeaker", 0x00000100), - ("stream", 0x00000200), - ("viewChannel", 0x00000400), - ("sendMessages", 0x00000800), - ("sendTtsMessages", 0x00001000), - ("manageMessages", 0x00002000), - ("embedLinks", 0x00004000), - ("attachFiles", 0x00008000), - ("readMessageHistory", 0x00010000), - ("mentionEveryone", 0x00020000), - ("useExternalEmojis", 0x00040000), - ("viewGuildInsights", 0x00080000), - ("connect", 0x00100000), - ("speak", 0x00200000), - ("muteMembers", 0x00400000), - ("deafenMembers", 0x00800000), - ("moveMembers", 0x01000000), - ("useVad", 0x02000000), - ("changeNickname", 0x04000000), - ("manageNicknames", 0x08000000), - ("manageRoles", 0x10000000), - ("manageWebhooks", 0x20000000), - ("manageEmojis", 0x4000000) - ] + "Permissions" + ''Word64 + [] + [ ("createInstantInvite", 1 `shiftL` 0) + , ("kickMembers", 1 `shiftL` 1) + , ("banMembers", 1 `shiftL` 2) + , ("administrator", 1 `shiftL` 3) + , ("manageChannels", 1 `shiftL` 4) + , ("manageGuild", 1 `shiftL` 5) + , ("addReactions", 1 `shiftL` 6) + , ("viewAuditLog", 1 `shiftL` 7) + , ("prioritySpeaker", 1 `shiftL` 8) + , ("stream", 1 `shiftL` 9) + , ("viewChannel", 1 `shiftL` 10) + , ("sendMessages", 1 `shiftL` 11) + , ("sendTtsMessages", 1 `shiftL` 12) + , ("manageMessages", 1 `shiftL` 13) + , ("embedLinks", 1 `shiftL` 14) + , ("attachFiles", 1 `shiftL` 15) + , ("readMessageHistory", 1 `shiftL` 16) + , ("mentionEveryone", 1 `shiftL` 17) + , ("useExternalEmojis", 1 `shiftL` 18) + , ("viewGuildInsights", 1 `shiftL` 19) + , ("connect", 1 `shiftL` 20) + , ("speak", 1 `shiftL` 21) + , ("muteMembers", 1 `shiftL` 22) + , ("deafenMembers", 1 `shiftL` 23) + , ("moveMembers", 1 `shiftL` 24) + , ("useVad", 1 `shiftL` 25) + , ("changeNickname", 1 `shiftL` 26) + , ("manageNicknames", 1 `shiftL` 27) + , ("manageRoles", 1 `shiftL` 28) + , ("manageWebhooks", 1 `shiftL` 29) + , ("manageEmojis", 1 `shiftL` 30) + , ("useApplicationCommands", 1 `shiftL` 31) + , ("requestToSPeak", 1 `shiftL` 32) + , ("manageEvents", 1 `shiftL` 33) + , ("manageThreads", 1 `shiftL` 34) + , ("createPublicThreads", 1 `shiftL` 35) + , ("createPrivateThreads", 1 `shiftL` 36) + , ("useExternalStickers", 1 `shiftL` 37) + , ("sendMessagesInThreads", 1 `shiftL` 38) + , ("useEmbeddedActivities", 1 `shiftL` 39) + , ("moderateMembers", 1 `shiftL` 40) + ] ) instance ToJSON Permissions where diff --git a/Calamity/Types/Model/Guild/Role.hs b/Calamity/Types/Model/Guild/Role.hs --- a/Calamity/Types/Model/Guild/Role.hs +++ b/Calamity/Types/Model/Guild/Role.hs @@ -1,35 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Guild roles module Calamity.Types.Model.Guild.Role (Role (..)) where -import Calamity.Internal.AesonThings import Calamity.Internal.IntColour +import Calamity.Internal.Utils import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake - -import Data.Aeson +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson import Data.Colour import Data.Text (Text) - -import GHC.Generics - -import Calamity.Internal.OverriddenVia -import Control.DeepSeq (NFData (rnf), rwhnf) -import TextShow -import qualified TextShow.Generic as TSG - -data Role' = Role' - { id :: Snowflake Role - , name :: Text - , color :: IntColour - , hoist :: Bool - , position :: Int - , permissions :: Permissions - , managed :: Bool - , mentionable :: Bool - } - deriving (Generic) - deriving (TextShow) via TSG.FromGeneric Role' - deriving (ToJSON, FromJSON) via CalamityJSON Role' +import Optics.TH +import qualified TextShow data Role = Role { id :: Snowflake Role @@ -41,13 +24,32 @@ , managed :: Bool , mentionable :: Bool } - deriving (Eq, Show, Generic) - deriving (TextShow, FromJSON, ToJSON) via OverriddenVia Role Role' + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Role deriving (HasID Role) via HasIDField "id" Role + deriving (Aeson.ToJSON) via CalamityToJSON Role -instance NFData Role where - rnf (Role id name color hoist position permissions managed mentionable) = - rnf id `seq` rnf name `seq` rwhnf color `seq` rnf hoist `seq` rnf position - `seq` rnf permissions - `seq` rnf managed - `seq` rnf mentionable +instance CalamityToJSON' Role where + toPairs Role {..} = + [ "id" .= id + , "name" .= name + , "color" .= IntColour color + , "position" .= position + , "permissions" .= permissions + , "managed" .= managed + , "mentionable" .= mentionable + ] + +instance Aeson.FromJSON Role where + parseJSON = Aeson.withObject "Role" $ \v -> + Role + <$> v .: "id" + <*> v .: "name" + <*> (fromIntColour <$> v .: "color") + <*> v .: "hoist" + <*> v .: "position" + <*> v .: "permissions" + <*> v .: "managed" + <*> v .: "mentionable" + +$(makeFieldLabelsNoPrefix ''Role) diff --git a/Calamity/Types/Model/Guild/UnavailableGuild.hs b/Calamity/Types/Model/Guild/UnavailableGuild.hs --- a/Calamity/Types/Model/Guild/UnavailableGuild.hs +++ b/Calamity/Types/Model/Guild/UnavailableGuild.hs @@ -1,27 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Guilds that are unavailable module Calamity.Types.Model.Guild.UnavailableGuild (UnavailableGuild (..)) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils import Calamity.Types.Model.Guild.Guild import Calamity.Types.Snowflake - -import Data.Aeson - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Data.Aeson ((.!=), (.:), (.:?)) +import qualified Data.Aeson as Aeson +import Optics.TH +import TextShow.TH data UnavailableGuild = UnavailableGuild { id :: Snowflake Guild , unavailable :: Bool } - deriving (Eq, Show, Generic) - deriving (TextShow) via TSG.FromGeneric UnavailableGuild - deriving (ToJSON) via CalamityJSON UnavailableGuild - deriving - (FromJSON) - via WithSpecialCases - '["disabled" `IfNoneThen` DefaultToFalse] - UnavailableGuild + deriving (Eq, Show) deriving (HasID Guild) via HasIDField "id" UnavailableGuild + deriving (Aeson.ToJSON) via CalamityToJSON UnavailableGuild + +instance CalamityToJSON' UnavailableGuild where + toPairs UnavailableGuild {..} = + [ "id" .= id + , "unavailable" .= unavailable + ] + +instance Aeson.FromJSON UnavailableGuild where + parseJSON = Aeson.withObject "UnavailableGuild" $ \v -> + UnavailableGuild + <$> v .: "id" + <*> v .:? "disabled" .!= False + +$(deriveTextShow ''UnavailableGuild) +$(makeFieldLabelsNoPrefix ''UnavailableGuild) diff --git a/Calamity/Types/Model/Interaction.hs b/Calamity/Types/Model/Interaction.hs --- a/Calamity/Types/Model/Interaction.hs +++ b/Calamity/Types/Model/Interaction.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Discord Interactions module Calamity.Types.Model.Interaction ( Interaction (..), @@ -9,9 +11,6 @@ ApplicationCommand, ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia -import Calamity.Internal.Utils import Calamity.Types.Model.Channel (Attachment, Channel, Partial) import Calamity.Types.Model.Channel.Component import Calamity.Types.Model.Channel.Message (Message) @@ -19,11 +18,14 @@ import Calamity.Types.Model.Guild.Member (Member) import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake -import Data.Aeson +import Data.Aeson ((.:), (.:?), (.!=)) +import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as H import Data.Scientific (toBoundedInteger) import qualified Data.Text as T -import GHC.Generics +import Optics.TH +import qualified TextShow +import TextShow.TH -- | Empty type to flag application IDs data Application @@ -34,8 +36,8 @@ newtype InteractionToken = InteractionToken { fromInteractionToken :: T.Text } - deriving stock (Show, Generic) - deriving (FromJSON, ToJSON) via T.Text + deriving stock (Show) + deriving (Aeson.FromJSON, Aeson.ToJSON) via T.Text data Interaction = Interaction { id :: Snowflake Interaction @@ -52,11 +54,27 @@ , locale :: Maybe T.Text , guildLocale :: Maybe T.Text } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON Interaction + deriving (Show) deriving (HasID Interaction) via HasIDField "id" Interaction deriving (HasID Application) via HasIDField "applicationID" Interaction +instance Aeson.FromJSON Interaction where + parseJSON = Aeson.withObject "Interaction" $ \v -> + Interaction + <$> v .: "id" + <*> v .: "application_id" + <*> v .: "type" + <*> v .:? "data" + <*> v .:? "guild_id" + <*> v .:? "channel_id" + <*> v .:? "member" + <*> v .:? "user" + <*> v .: "token" + <*> v .: "version" + <*> v .:? "message" + <*> v .:? "locale" + <*> v .:? "guild_locale" + data InteractionData = InteractionData { id :: Maybe (Snowflake ApplicationCommand) , name :: Maybe T.Text @@ -67,21 +85,22 @@ , componentType :: Maybe ComponentType , values :: Maybe [T.Text] , targetID :: Maybe (Snowflake ()) - , components :: Maybe [Value] + , components :: Maybe [Aeson.Value] } - deriving (Show, Generic) - deriving (FromJSON) via CalamityJSON InteractionData + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow InteractionData -data ResolvedInteractionData' = ResolvedInteractionData' - { users :: CalamityFromStringShow (H.HashMap (Snowflake User) User) - , members :: CalamityFromStringShow (H.HashMap (Snowflake Member) Member) - , roles :: CalamityFromStringShow (H.HashMap (Snowflake Role) Role) - , channels :: CalamityFromStringShow (H.HashMap (Snowflake Channel) (Partial Channel)) - , messages :: CalamityFromStringShow (H.HashMap (Snowflake Message) (Partial Message)) - , attachments :: CalamityFromStringShow (H.HashMap (Snowflake Attachment) Attachment) - } - deriving (Generic) - deriving (FromJSON) via CalamityJSON ResolvedInteractionData' +instance Aeson.FromJSON InteractionData where + parseJSON = Aeson.withObject "InteractionData" $ \v -> + InteractionData + <$> v .:? "id" + <*> v .:? "name" + <*> v .:? "resolved" + <*> v .:? "custom_id" + <*> v .:? "component_type" + <*> v .:? "values" + <*> v .:? "target_id" + <*> v .:? "components" data ResolvedInteractionData = ResolvedInteractionData { users :: H.HashMap (Snowflake User) User @@ -91,24 +110,41 @@ , messages :: H.HashMap (Snowflake Message) (Partial Message) , attachments :: H.HashMap (Snowflake Attachment) Attachment } - deriving (Show, Generic) - deriving - (FromJSON) - via OverriddenVia ResolvedInteractionData ResolvedInteractionData' + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow ResolvedInteractionData +instance Aeson.FromJSON ResolvedInteractionData where + parseJSON = Aeson.withObject "ResolvedInteractionData" $ \v -> + ResolvedInteractionData + <$> v .:? "users" .!= H.empty + <*> v .:? "members" .!= H.empty + <*> v .:? "roles" .!= H.empty + <*> v .:? "channels" .!= H.empty + <*> v .:? "messages" .!= H.empty + <*> v .:? "attachments" .!= H.empty + data InteractionType = PingType | ApplicationCommandType | MessageComponentType | ApplicationCommandAutoCompleteType | ModalSubmitType - deriving (Eq, Show, Generic) + deriving (Eq, Show) -instance FromJSON InteractionType where - parseJSON = withScientific "InteractionType" $ \n -> case toBoundedInteger @Int n of +instance Aeson.FromJSON InteractionType where + parseJSON = Aeson.withScientific "InteractionType" $ \n -> case toBoundedInteger @Int n of Just 1 -> pure PingType Just 2 -> pure ApplicationCommandType Just 3 -> pure MessageComponentType Just 4 -> pure ApplicationCommandAutoCompleteType Just 5 -> pure ModalSubmitType _ -> fail $ "Invalid InteractionType: " <> show n + +$(deriveTextShow ''InteractionToken) +$(deriveTextShow ''InteractionType) +$(deriveTextShow ''Interaction) +$(makeFieldLabelsNoPrefix ''InteractionToken) +$(makeFieldLabelsNoPrefix ''Interaction) +$(makeFieldLabelsNoPrefix ''InteractionData) +$(makeFieldLabelsNoPrefix ''ResolvedInteractionData) +$(makeFieldLabelsNoPrefix ''InteractionType) diff --git a/Calamity/Types/Model/Presence.hs b/Calamity/Types/Model/Presence.hs --- a/Calamity/Types/Model/Presence.hs +++ b/Calamity/Types/Model/Presence.hs @@ -1,7 +1,8 @@ -- | User presences -module Calamity.Types.Model.Presence - ( module Calamity.Types.Model.Presence.Presence - , module Calamity.Types.Model.Presence.Activity ) where +module Calamity.Types.Model.Presence ( + module Calamity.Types.Model.Presence.Presence, + module Calamity.Types.Model.Presence.Activity, +) where -import Calamity.Types.Model.Presence.Activity -import Calamity.Types.Model.Presence.Presence +import Calamity.Types.Model.Presence.Activity +import Calamity.Types.Model.Presence.Presence diff --git a/Calamity/Types/Model/Presence/Activity.hs b/Calamity/Types/Model/Presence/Activity.hs --- a/Calamity/Types/Model/Presence/Activity.hs +++ b/Calamity/Types/Model/Presence/Activity.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | User activities module Calamity.Types.Model.Presence.Activity ( Activity (..), @@ -9,19 +11,18 @@ ActivitySecrets (..), ) where -import Calamity.Internal.AesonThings -import Calamity.Internal.OverriddenVia import Calamity.Internal.UnixTimestamp +import Calamity.Internal.Utils import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Scientific import Data.Text (Text) import Data.Time (UTCTime) import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import qualified TextShow +import TextShow.TH data ActivityType = Game @@ -29,18 +30,17 @@ | Listening | Custom | Other Int - deriving (Eq, Generic, Show, NFData) - deriving (TextShow) via TSG.FromGeneric ActivityType + deriving (Eq, Show) -instance ToJSON ActivityType where - toJSON Game = Number 0 - toJSON Streaming = Number 1 - toJSON Listening = Number 2 - toJSON (Other n) = Number $ fromIntegral n - toJSON Custom = Number 4 +instance Aeson.ToJSON ActivityType where + toJSON Game = Aeson.Number 0 + toJSON Streaming = Aeson.Number 1 + toJSON Listening = Aeson.Number 2 + toJSON Custom = Aeson.Number 4 + toJSON (Other n) = Aeson.Number $ fromIntegral n -instance FromJSON ActivityType where - parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of +instance Aeson.FromJSON ActivityType where + parseJSON = Aeson.withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of Just v -> case v of 0 -> pure Game 1 -> pure Streaming @@ -51,7 +51,7 @@ data Activity = Activity { name :: Text - , type_ :: !ActivityType + , type_ :: ActivityType , url :: Maybe Text , timestamps :: Maybe ActivityTimestamps , applicationID :: Maybe (Snowflake ()) @@ -63,10 +63,41 @@ , instance_ :: Maybe Bool , flags :: Maybe Word64 } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric Activity - deriving (ToJSON, FromJSON) via CalamityJSON Activity + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON Activity +instance CalamityToJSON' Activity where + toPairs Activity {..} = + [ "name" .= name + , "type" .= type_ + , "url" .?= url + , "timestamps" .?= timestamps + , "application_id" .?= applicationID + , "details" .?= details + , "state" .?= state + , "party" .?= party + , "assets" .?= assets + , "secrets" .?= secrets + , "instance" .?= instance_ + , "flags" .?= flags + ] + +instance Aeson.FromJSON Activity where + parseJSON = Aeson.withObject "Activity" $ \v -> + Activity + <$> v .: "name" + <*> v .: "type" + <*> v .:? "url" + <*> v .:? "timestamps" + <*> v .:? "application_id" + <*> v .:? "details" + <*> v .:? "state" + <*> v .:? "party" + <*> v .:? "assets" + <*> v .:? "secrets" + <*> v .:? "instance" + <*> v .:? "flags" + -- | Make an 'Activity' with all optional fields set to Nothing activity :: Text -> ActivityType -> Activity activity !name !type_ = @@ -85,44 +116,99 @@ , flags = Nothing } -data ActivityTimestamps' = ActivityTimestamps' - { start :: !(Maybe UnixTimestamp) - , end :: !(Maybe UnixTimestamp) - } - deriving (Generic, NFData) - deriving (ToJSON, FromJSON) via CalamityJSON ActivityTimestamps' - deriving (TextShow) via TSG.FromGeneric ActivityTimestamps' - data ActivityTimestamps = ActivityTimestamps - { start :: !(Maybe UTCTime) - , end :: !(Maybe UTCTime) + { start :: Maybe UTCTime + , end :: Maybe UTCTime } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow, ToJSON, FromJSON) via OverriddenVia ActivityTimestamps ActivityTimestamps' + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow ActivityTimestamps + deriving (Aeson.ToJSON) via CalamityToJSON ActivityTimestamps +instance CalamityToJSON' ActivityTimestamps where + toPairs ActivityTimestamps {..} = + [ "start" .?= fmap UnixTimestamp start + , "end" .?= fmap UnixTimestamp end + ] + +instance Aeson.FromJSON ActivityTimestamps where + parseJSON = Aeson.withObject "ActivityTimestamps" $ \v -> + ActivityTimestamps + <$> (fmap unUnixTimestamp <$> v .:? "start") + <*> (fmap unUnixTimestamp <$> v .:? "end") + data ActivityParty = ActivityParty { id :: Maybe Text , size :: Maybe (Int, Int) } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric ActivityParty - deriving (ToJSON, FromJSON) via CalamityJSON ActivityParty + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ActivityParty +instance CalamityToJSON' ActivityParty where + toPairs ActivityParty {..} = + [ "id" .?= id + , "size" .?= size + ] + +instance Aeson.FromJSON ActivityParty where + parseJSON = Aeson.withObject "ActivityParty" $ \v -> + ActivityParty + <$> v .:? "id" + <*> v .:? "size" + data ActivityAssets = ActivityAssets { largeImage :: Maybe Text , largeText :: Maybe Text , smallImage :: Maybe Text , smallText :: Maybe Text } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric ActivityAssets - deriving (ToJSON, FromJSON) via CalamityJSON ActivityAssets + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ActivityAssets +instance CalamityToJSON' ActivityAssets where + toPairs ActivityAssets {..} = + [ "large_image" .?= largeImage + , "large_text" .?= largeText + , "small_image" .?= smallImage + , "small_text" .?= smallText + ] + +instance Aeson.FromJSON ActivityAssets where + parseJSON = Aeson.withObject "ActivityAssets" $ \v -> + ActivityAssets + <$> v .:? "large_image" + <*> v .:? "large_text" + <*> v .:? "small_image" + <*> v .:? "small_text" + data ActivitySecrets = ActivitySecrets { join :: Maybe Text , spectate :: Maybe Text , match :: Maybe Text } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric ActivitySecrets - deriving (ToJSON, FromJSON) via CalamityJSON ActivitySecrets + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ActivitySecrets + +instance CalamityToJSON' ActivitySecrets where + toPairs ActivitySecrets {..} = + [ "join" .?= join + , "spectate" .?= spectate + , "match" .?= match + ] + +instance Aeson.FromJSON ActivitySecrets where + parseJSON = Aeson.withObject "ActivitySecrets" $ \v -> + ActivitySecrets + <$> v .:? "join" + <*> v .:? "spectate" + <*> v .:? "match" + +$(deriveTextShow ''ActivityType) +$(deriveTextShow ''ActivityParty) +$(deriveTextShow ''ActivityAssets) +$(deriveTextShow ''ActivitySecrets) +$(deriveTextShow ''Activity) +$(makeFieldLabelsNoPrefix ''Activity) +$(makeFieldLabelsNoPrefix ''ActivityTimestamps) +$(makeFieldLabelsNoPrefix ''ActivityParty) +$(makeFieldLabelsNoPrefix ''ActivityAssets) +$(makeFieldLabelsNoPrefix ''ActivitySecrets) diff --git a/Calamity/Types/Model/Presence/Presence.hs b/Calamity/Types/Model/Presence/Presence.hs --- a/Calamity/Types/Model/Presence/Presence.hs +++ b/Calamity/Types/Model/Presence/Presence.hs @@ -1,20 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | User presences module Calamity.Types.Model.Presence.Presence ( Presence (..), ClientStatus (..), ) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Presence.Activity import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.DeepSeq (NFData) -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data Presence = Presence { user :: Snowflake User @@ -23,21 +24,44 @@ , activities :: [Activity] , clientStatus :: ClientStatus } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric Presence - deriving - (FromJSON) - via WithSpecialCases - '["user" `ExtractFieldFrom` "id"] - Presence + deriving (Eq, Show) deriving (HasID User) via HasIDField "user" Presence deriving (HasID Guild) via HasIDField "guildID" Presence +instance Aeson.FromJSON Presence where + parseJSON = Aeson.withObject "Presence" $ \v -> do + u :: Aeson.Object <- v .: "user" + + Presence + <$> u .: "id" + <*> v .: "guild_id" + <*> v .: "status" + <*> v .: "activities" + <*> v .: "client_status" + data ClientStatus = ClientStatus { desktop :: Maybe Text , mobile :: Maybe Text , web :: Maybe Text } - deriving (Eq, Show, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric ClientStatus - deriving (ToJSON, FromJSON) via CalamityJSON ClientStatus + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ClientStatus + +instance CalamityToJSON' ClientStatus where + toPairs ClientStatus {..} = + [ "desktop" .?= desktop + , "mobile" .?= mobile + , "web" .?= web + ] + +instance Aeson.FromJSON ClientStatus where + parseJSON = Aeson.withObject "ClientStatus" $ \v -> + ClientStatus + <$> v .:? "desktop" + <*> v .:? "mobile" + <*> v .:? "web" + +$(deriveTextShow ''ClientStatus) +$(deriveTextShow ''Presence) +$(makeFieldLabelsNoPrefix ''Presence) +$(makeFieldLabelsNoPrefix ''ClientStatus) diff --git a/Calamity/Types/Model/User.hs b/Calamity/Types/Model/User.hs --- a/Calamity/Types/Model/User.hs +++ b/Calamity/Types/Model/User.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | A User module Calamity.Types.Model.User ( User (..), @@ -5,17 +7,15 @@ StatusType (..), ) where -import Calamity.Internal.AesonThings import {-# SOURCE #-} Calamity.Types.Model.Guild.Member import Calamity.Types.Partial import Calamity.Types.Snowflake -import Control.DeepSeq -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data User = User { id :: Snowflake User @@ -29,31 +29,44 @@ , flags :: Maybe Word64 , premiumType :: Maybe Word64 } - deriving (Show, Eq, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric User - deriving (ToJSON, FromJSON) via CalamityJSON User + deriving (Show, Eq) deriving (HasID User) via HasIDField "id" User deriving (HasID Member) via HasIDFieldCoerce' "id" User +instance Aeson.FromJSON User where + parseJSON = Aeson.withObject "User" $ \v -> + User + <$> v .: "id" + <*> v .: "username" + <*> v .: "discriminator" + <*> v .:? "bot" + <*> v .:? "avatar" + <*> v .:? "mfa_enabled" + <*> v .:? "verified" + <*> v .:? "email" + <*> v .:? "flags" + <*> v .:? "premium_type" + newtype instance Partial User = PartialUser { id :: Snowflake User } - deriving (Show, Eq, Generic) - deriving (TextShow) via TSG.FromGeneric (Partial User) - deriving (ToJSON, FromJSON) via CalamityJSON (Partial User) + deriving (Show, Eq) deriving (HasID User) via HasIDField "id" (Partial User) +instance Aeson.FromJSON (Partial User) where + parseJSON = Aeson.withObject "Partial User" $ \v -> + PartialUser <$> v .: "id" + data StatusType = Idle | DND | Online | Offline | Invisible - deriving (Eq, Show, Enum, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric StatusType + deriving (Eq, Show, Enum) -instance FromJSON StatusType where - parseJSON = withText "StatusType" $ \case +instance Aeson.FromJSON StatusType where + parseJSON = Aeson.withText "StatusType" $ \case "idle" -> pure Idle "dnd" -> pure DND "online" -> pure Online @@ -61,11 +74,18 @@ "invisible" -> pure Invisible _ -> fail "Unknown status type" -instance ToJSON StatusType where +instance Aeson.ToJSON StatusType where toJSON = - String . \case + Aeson.toJSON @Text . \case Idle -> "idle" DND -> "dnd" Online -> "online" Offline -> "offline" Invisible -> "invisible" + +$(deriveTextShow ''User) +$(deriveTextShow 'PartialUser) +$(deriveTextShow ''StatusType) +$(makeFieldLabelsNoPrefix ''User) +$(makeFieldLabelsNoPrefix 'PartialUser) +$(makeFieldLabelsNoPrefix ''StatusType) diff --git a/Calamity/Types/Model/Voice.hs b/Calamity/Types/Model/Voice.hs --- a/Calamity/Types/Model/Voice.hs +++ b/Calamity/Types/Model/Voice.hs @@ -1,7 +1,8 @@ -- | Voice data types -module Calamity.Types.Model.Voice - ( module Calamity.Types.Model.Voice.VoiceState - , module Calamity.Types.Model.Voice.VoiceRegion ) where +module Calamity.Types.Model.Voice ( + module Calamity.Types.Model.Voice.VoiceState, + module Calamity.Types.Model.Voice.VoiceRegion, +) where -import Calamity.Types.Model.Voice.VoiceRegion -import Calamity.Types.Model.Voice.VoiceState +import Calamity.Types.Model.Voice.VoiceRegion +import Calamity.Types.Model.Voice.VoiceState diff --git a/Calamity/Types/Model/Voice/VoiceRegion.hs b/Calamity/Types/Model/Voice/VoiceRegion.hs --- a/Calamity/Types/Model/Voice/VoiceRegion.hs +++ b/Calamity/Types/Model/Voice/VoiceRegion.hs @@ -1,16 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | Voice regions module Calamity.Types.Model.Voice.VoiceRegion (VoiceRegion (..)) where -import Calamity.Internal.AesonThings import Calamity.Types.Snowflake - -import Data.Aeson +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson import Data.Text (Text) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH +import Calamity.Internal.Utils data VoiceRegion = VoiceRegion { id :: Snowflake VoiceRegion @@ -20,6 +19,28 @@ , deprecated :: Bool , custom :: Bool } - deriving (Show, Eq, Generic) - deriving (TextShow) via TSG.FromGeneric VoiceRegion - deriving (ToJSON, FromJSON) via CalamityJSON VoiceRegion + deriving (Show, Eq) + deriving (Aeson.ToJSON) via CalamityToJSON VoiceRegion + +instance CalamityToJSON' VoiceRegion where + toPairs VoiceRegion {..} = + [ "id" .= id + , "name" .= name + , "vip" .= vip + , "optimal" .= optimal + , "deprecated" .= deprecated + , "custom" .= custom + ] + +instance Aeson.FromJSON VoiceRegion where + parseJSON = Aeson.withObject "VoiceRegion" $ \v -> + VoiceRegion + <$> v .: "id" + <*> v .: "name" + <*> v .: "vip" + <*> v .: "optimal" + <*> v .: "deprecated" + <*> v .: "custom" + +$(deriveTextShow ''VoiceRegion) +$(makeFieldLabelsNoPrefix ''VoiceRegion) diff --git a/Calamity/Types/Model/Voice/VoiceState.hs b/Calamity/Types/Model/Voice/VoiceState.hs --- a/Calamity/Types/Model/Voice/VoiceState.hs +++ b/Calamity/Types/Model/Voice/VoiceState.hs @@ -1,19 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + module Calamity.Types.Model.Voice.VoiceState (VoiceState (..)) where -import Calamity.Internal.AesonThings +import Calamity.Internal.Utils import Calamity.Types.Model.Channel.Guild.Voice import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake - -import Data.Aeson +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as Aeson import Data.Text (Text) - -import GHC.Generics - -import Control.DeepSeq (NFData) -import TextShow -import qualified TextShow.Generic as TSG +import Optics.TH +import TextShow.TH data VoiceState = VoiceState { guildID :: Maybe (Snowflake Guild) @@ -26,6 +24,34 @@ , selfMute :: Bool , suppress :: Bool } - deriving (Show, Eq, Generic, NFData) - deriving (TextShow) via TSG.FromGeneric VoiceState - deriving (ToJSON, FromJSON) via CalamityJSON VoiceState + deriving (Show, Eq) + deriving (Aeson.ToJSON) via CalamityToJSON VoiceState + +instance CalamityToJSON' VoiceState where + toPairs VoiceState {..} = + [ "guild_id" .= guildID + , "channel_id" .= channelID + , "user_id" .= userID + , "session_id" .= sessionID + , "deaf" .= deaf + , "mute" .= mute + , "self_deaf" .= selfDeaf + , "self_mute" .= selfMute + , "suppress" .= suppress + ] + +instance Aeson.FromJSON VoiceState where + parseJSON = Aeson.withObject "VoiceState" $ \v -> + VoiceState + <$> v .:? "guild_id" + <*> v .:? "channel_id" + <*> v .: "user_id" + <*> v .: "session_id" + <*> v .: "deaf" + <*> v .: "mute" + <*> v .: "self_deaf" + <*> v .: "self_mute" + <*> v .: "suppress" + +$(deriveTextShow ''VoiceState) +$(makeFieldLabelsNoPrefix ''VoiceState) diff --git a/Calamity/Types/Partial.hs b/Calamity/Types/Partial.hs --- a/Calamity/Types/Partial.hs +++ b/Calamity/Types/Partial.hs @@ -1,5 +1,4 @@ -- | Partial data family -module Calamity.Types.Partial - ( Partial ) where +module Calamity.Types.Partial (Partial) where data family Partial t diff --git a/Calamity/Types/Snowflake.hs b/Calamity/Types/Snowflake.hs --- a/Calamity/Types/Snowflake.hs +++ b/Calamity/Types/Snowflake.hs @@ -1,38 +1,33 @@ -- | The snowflake type -module Calamity.Types.Snowflake - ( Snowflake(..) - , HasID(..) - , type HasID' - , HasIDField(..) - , HasIDFieldCoerce(..) - , type HasIDFieldCoerce' - , coerceSnowflake ) where - -import Control.DeepSeq -import Control.Lens - -import Data.Aeson -import Data.Data -import Data.Generics.Product.Fields -import Data.Hashable -import Data.Kind -import Data.Text.Read -import qualified Data.Vector.Unboxing as U -import Data.Word -import Data.Bits - -import GHC.Generics +module Calamity.Types.Snowflake ( + Snowflake (..), + HasID (..), + type HasID', + HasIDField (..), + HasIDFieldCoerce (..), + type HasIDFieldCoerce', + coerceSnowflake, +) where -import TextShow +import Data.Aeson +import Data.Bits +import Data.Data +import Data.Hashable +import Data.Kind +import Data.Text.Read +import qualified Data.Vector.Unboxing as U +import Data.Word +import GHC.Records (HasField (getField)) +import TextShow -- 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, Eq, Ord, Data ) - deriving newtype ( Show, TextShow, FromJSONKey ) - deriving newtype ( NFData, ToJSONKey, U.Unboxable ) + deriving (Eq, Ord, Data) + deriving newtype (Show, TextShow, FromJSONKey) + deriving newtype (ToJSONKey, U.Unboxable) -- 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 @@ -40,9 +35,9 @@ instance Hashable (Snowflake t) where hashWithSalt salt (Snowflake a) = let initial = fromIntegral @_ @Word64 $ hashWithSalt salt a - round1 = ((initial `shiftR` 30) `xor` initial) * 0xbf58476d1ce4e5b9 - round2 = ((round1 `shiftR` 27) `xor` round1) * 0xbf58476d1ce4e5b9 - round3 = ((round2 `shiftR` 31) `xor` round2) + round1 = (initial `shiftR` 30 `xor` initial) * 0xbf58476d1ce4e5b9 + round2 = (round1 `shiftR` 27 `xor` round1) * 0xbf58476d1ce4e5b9 + round3 = (round2 `shiftR` 31 `xor` round2) in fromIntegral @_ @Int round3 instance ToJSON (Snowflake t) where @@ -52,7 +47,7 @@ parseJSON = withText "Snowflake" $ \t -> do n <- case decimal t of Right (n, _) -> pure n - Left e -> fail e + Left e -> fail e pure $ Snowflake n coerceSnowflake :: Snowflake a -> Snowflake b @@ -60,7 +55,6 @@ -- | A typeclass for types that contain snowflakes of type `b` class HasID b a where - -- | Retrieve the ID from the type getID :: a -> Snowflake b @@ -69,17 +63,18 @@ -- | A newtype wrapper for deriving HasID generically newtype HasIDField field a = HasIDField a -instance (HasID b c, HasField' field a c) => HasID b (HasIDField field a) where - getID (HasIDField a) = getID $ a ^. field' @field +instance (HasID b c, HasField field a c) => HasID b (HasIDField field a) where + getID (HasIDField a) = getID @b @c $ getField @field a --- | A data `a` which contains an ID of type `Snowflake c` --- which should be swapped with `Snowflake b` upon fetching +{- | A data `a` which contains an ID of type `Snowflake c` + which should be swapped with `Snowflake b` upon fetching +-} newtype HasIDFieldCoerce field a c = HasIDFieldCoerce a type HasIDFieldCoerce' field a = HasIDFieldCoerce field a a -instance (HasID c d, HasField' field a d) => HasID b (HasIDFieldCoerce field a c) where - getID (HasIDFieldCoerce a) = coerceSnowflake . getID @c $ a ^. field' @field +instance (HasID c d, HasField field a d) => HasID b (HasIDFieldCoerce field a c) where + getID (HasIDFieldCoerce a) = coerceSnowflake . getID @c $ getField @field a instance HasID a (Snowflake a) where getID = id diff --git a/Calamity/Types/Tellable.hs b/Calamity/Types/Tellable.hs --- a/Calamity/Types/Tellable.hs +++ b/Calamity/Types/Tellable.hs @@ -23,18 +23,17 @@ import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake -import Control.Lens import Data.Default.Class import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Lazy as L -import GHC.Generics +import Optics import qualified Polysemy as P import qualified Polysemy.Error as P -- | A wrapper type for allowing mentions newtype TMention a = TMention (Snowflake a) - deriving stock (Show, Generic) + deriving stock (Show) {- | Things that can be used to send a message @@ -74,15 +73,15 @@ -- | Add a 'User' id to the list of allowed user mentions instance ToMessage (TMention User) where - intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [s]) + 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]) + 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]) + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles %~ (<> [s])) fixupActionRow :: Component -> Component fixupActionRow r@(ActionRow' _) = r diff --git a/Calamity/Types/Token.hs b/Calamity/Types/Token.hs --- a/Calamity/Types/Token.hs +++ b/Calamity/Types/Token.hs @@ -1,21 +1,20 @@ --- | Discord tokens -module Calamity.Types.Token - ( Token(..) - , formatToken - , rawToken ) where - -import Data.Text +{-# LANGUAGE TemplateHaskell #-} -import GHC.Generics +-- | Discord tokens +module Calamity.Types.Token ( + Token (..), + formatToken, + rawToken, +) where -import TextShow -import qualified TextShow.Generic as TSG +import Data.Text (Text) +import Optics.TH +import TextShow.TH (deriveTextShow) data Token = BotToken Text | UserToken Text - deriving ( Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric Token + deriving (Show) formatToken :: Token -> Text formatToken (BotToken t) = "Bot " <> t @@ -24,3 +23,6 @@ rawToken :: Token -> Text rawToken (BotToken t) = t rawToken (UserToken t) = t + +$(deriveTextShow ''Token) +$(makeFieldLabelsNoPrefix ''Token) diff --git a/Calamity/Types/Upgradeable.hs b/Calamity/Types/Upgradeable.hs --- a/Calamity/Types/Upgradeable.hs +++ b/Calamity/Types/Upgradeable.hs @@ -11,12 +11,8 @@ import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake - import Control.Applicative -import Control.Lens - -import Data.Generics.Sum.Constructors - +import Optics import qualified Polysemy as P import qualified Polysemy.Fail as P import qualified Polysemy.NonDet as P @@ -47,12 +43,12 @@ where getcache = P.failToNonDet $ do Just g <- getGuild gid - Just m <- pure (g ^. #members . at mid) + Just m <- pure (g ^. #members % at mid) pure m gethttp = P.failToNonDet $ do Right m <- invoke $ H.GetGuildMember gid (coerceSnowflake @_ @User mid) -- getcache could have failed becuase the member wasn't cached - updateGuild gid (#members . at mid ?~ m) + updateGuild gid (#members % at mid ?~ m) pure m instance Upgradeable Guild (Snowflake Guild) where @@ -65,7 +61,7 @@ insertChannel :: BotC r => Channel -> P.Sem r () insertChannel (DMChannel' dm) = setDM dm insertChannel (GuildChannel' ch) = - updateGuild (getID ch) (#channels . at (getID @GuildChannel ch) ?~ ch) + updateGuild (getID ch) (#channels % at (getID @GuildChannel ch) ?~ ch) insertChannel _ = pure () instance Upgradeable Channel (Snowflake Channel) where @@ -85,7 +81,8 @@ gethttp = P.failToNonDet $ do Right c <- invoke $ H.GetChannel (coerceSnowflake @_ @Channel cid) insertChannel c - maybeToAlt (c ^? _Ctor @"GuildChannel'") + GuildChannel' c' <- pure c + pure c' instance Upgradeable VoiceChannel (Snowflake VoiceChannel) where upgrade s = upgrade (coerceSnowflake @_ @Channel s) <&> \case @@ -118,11 +115,11 @@ where getcache = P.failToNonDet $ do Just g <- getGuild gid - Just m <- pure (g ^. #emojis . at eid) + Just m <- pure (g ^. #emojis % at eid) pure m gethttp = P.failToNonDet $ do Right e <- invoke $ H.GetGuildEmoji gid eid - updateGuild gid (#emojis . at eid ?~ e) + updateGuild gid (#emojis % at eid ?~ e) pure e instance Upgradeable Role (Snowflake Guild, Snowflake Role) where @@ -130,11 +127,11 @@ where getcache = P.failToNonDet $ do Just g <- getGuild gid - Just r <- pure (g ^. #roles . at rid) + Just r <- pure (g ^. #roles % at rid) pure r gethttp = P.failToNonDet $ do Right rs <- invoke $ H.GetGuildRoles gid let sm = SM.fromList rs - updateGuild gid (#roles <>~ sm) + updateGuild gid (#roles %~ (<> sm)) Just r <- pure (sm ^. at rid) pure r diff --git a/Calamity/Utils/Message.hs b/Calamity/Utils/Message.hs --- a/Calamity/Utils/Message.hs +++ b/Calamity/Utils/Message.hs @@ -29,19 +29,19 @@ DMChannel, GuildChannel, Message, - MessageReference(MessageReference), + 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 as T +import GHC.Records (HasField (getField)) +import Optics import TextShow (TextShow (showt)) zws :: IsString s => s @@ -151,13 +151,13 @@ spoiler content = "||" <> escapeSpoilers content <> "||" fmtEmoji :: Emoji -> T.Text -fmtEmoji Emoji{id, name, animated} = "<" <> ifanim <> ":" <> name <> ":" <> showt id <> ">" - where - ifanim = if animated then "a" else "" +fmtEmoji Emoji {id, name, animated} = "<" <> ifanim <> ":" <> name <> ":" <> showt id <> ">" + where + ifanim = if animated then "a" else "" -- | Format a 'User' or 'Member' into the format of @username#discriminator@ -displayUser :: (HasField' "username" a T.Text, HasField' "discriminator" a T.Text) => a -> T.Text -displayUser u = u ^. field' @"username" <> "#" <> u ^. field' @"discriminator" +displayUser :: (HasField "username" a T.Text, HasField "discriminator" a T.Text) => a -> T.Text +displayUser u = getField @"username" u <> "#" <> getField @"discriminator" u mentionSnowflake :: T.Text -> Snowflake a -> T.Text mentionSnowflake tag s = "<" <> tag <> showt s <> ">" @@ -221,11 +221,12 @@ 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 :: + -- | The message to reply to + Message -> + -- | If discord should error when replying to deleted messages + Bool -> + MessageReference asReference msg failIfNotExists = MessageReference (Just $ getID @Message msg) diff --git a/Calamity/Utils/Permissions.hs b/Calamity/Utils/Permissions.hs --- a/Calamity/Utils/Permissions.hs +++ b/Calamity/Utils/Permissions.hs @@ -14,45 +14,48 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Calamity.Types.Upgradeable - -import Control.Lens - -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Flags import qualified Data.Vector.Unboxing as V -import Data.Generics.Product.Fields - +import Optics import qualified Polysemy as P import Data.Foldable (Foldable(foldl')) +import qualified Calamity.Internal.SnowflakeMap as SM -- | Calculate a 'Member'\'s 'Permissions' in a 'Guild' basePermissions :: Guild -> Member -> Permissions basePermissions g m - | (g ^. #ownerID == getID m) = allFlags - | otherwise = let everyoneRole = g ^. #roles . at (coerceSnowflake $ getID @Guild g) + | g ^. #ownerID == getID m = allFlags + | otherwise = let everyoneRole = g ^. #roles % at (coerceSnowflake $ getID @Guild g) permsEveryone = maybe noFlags (^. #permissions) everyoneRole roleIDs = V.toList $ m ^. #roles - rolePerms = catMaybes $ map (\rid -> g ^? #roles . ix rid . #permissions) roleIDs + rolePerms = mapMaybe (\rid -> g ^? #roles % ix rid % #permissions) roleIDs perms = foldl' andFlags noFlags (permsEveryone:rolePerms) in if perms .<=. administrator then allFlags else perms +overwrites :: GuildChannel -> SM.SnowflakeMap Overwrite +overwrites (GuildTextChannel c) = c ^. #permissionOverwrites +overwrites (GuildVoiceChannel c) = c ^. #permissionOverwrites +overwrites (GuildCategory c) = c ^. #permissionOverwrites +overwrites _ = SM.empty + -- | Apply any 'Overwrite's for a 'GuildChannel' onto some 'Permissions' applyOverwrites :: GuildChannel -> Member -> Permissions -> Permissions applyOverwrites c m p | p .<=. administrator = allFlags | otherwise = - let everyoneOverwrite = c ^. field' @"permissionOverwrites" . at (coerceSnowflake $ getID @Guild c) + let everyoneOverwrite = overwrites c ^. at (coerceSnowflake $ getID @Guild c) everyoneAllow = maybe noFlags (^. #allow) everyoneOverwrite everyoneDeny = maybe noFlags (^. #deny) everyoneOverwrite p' = p .-. everyoneDeny .+. everyoneAllow roleOverwriteIDs = map (coerceSnowflake @_ @Overwrite) . V.toList $ m ^. #roles - roleOverwrites = catMaybes $ map (\oid -> c ^? field' @"permissionOverwrites" . ix oid) roleOverwriteIDs - roleAllow = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #allow) - roleDeny = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #deny) + roleOverwrites = mapMaybe (\oid -> overwrites c ^? ix oid) roleOverwriteIDs + roleAllow = foldl' andFlags noFlags (roleOverwrites ^.. traversed % #allow) + roleDeny = foldl' andFlags noFlags (roleOverwrites ^.. traversed % #deny) p'' = p' .-. roleDeny .+. roleAllow - memberOverwrite = c ^. field' @"permissionOverwrites" . at (coerceSnowflake @_ @Overwrite $ getID @Member m) + memberOverwrite = overwrites c ^. at (coerceSnowflake @_ @Overwrite $ getID @Member m) memberAllow = maybe noFlags (^. #allow) memberOverwrite memberDeny = maybe noFlags (^. #deny) memberOverwrite p''' = p'' .-. memberDeny .+. memberAllow diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Changelog for Calamity +## 0.5.0.0 + ++ Replaced lens with optics internally, you should use optics for field labels now. ++ Generic instances have been removed from library data types. ++ Internally, all aeson instances are manually implemented now, + instead of using generic. Expect a 5x improvement in compile time. ++ The `game` field on `StatusUpdateData` was changed to `activities :: [Activity]` + +## 0.4.0.0 + ++ DSL functions no longer use a concrete effect list prefix. + ## 0.3.0.0 + The discord api version has been moved from v9 to v10. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -58,7 +58,7 @@ build-depends: base >= 4.13 && < 5 , calamity >= 0.3.0.0 - , text >= 1.2 && < 2.1 + , optics >= 0.4.1 && < 0.5 , lens >= 5.1 && < 6 , di-polysemy ^>= 0.2 , di >= 1.3 && < 2 @@ -76,16 +76,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE BlockArguments #-} - {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} module Main (main) where @@ -96,12 +96,11 @@ import qualified Calamity.Interactions as I import Calamity.Metrics.Noop import Control.Concurrent -import Control.Lens +import Optics import Control.Monad import qualified Data.Text as T import qualified Di import qualified DiPolysemy as DiP -import GHC.Generics import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.State as P @@ -112,7 +111,8 @@ { numOptions :: Int , selected :: Maybe T.Text } - deriving (Generic) + +$(makeFieldLabelsNoPrefix ''MyViewState) main :: IO () main = do diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: calamity -version: 0.4.0.0 +version: 0.5.0.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.10.7 + GHC == 8.10.7, GHC == 9.2.2 extra-source-files: README.md ChangeLog.md @@ -69,14 +69,11 @@ Calamity.Interactions.Eff Calamity.Interactions.Utils Calamity.Interactions.View - Calamity.Internal.AesonThings Calamity.Internal.BoundedStore Calamity.Internal.ConstructorName Calamity.Internal.IntColour Calamity.Internal.LocalWriter - Calamity.Internal.OverriddenVia Calamity.Internal.RunIntoIO - Calamity.Internal.ShapeCoerce Calamity.Internal.SnowflakeMap Calamity.Internal.UnixTimestamp Calamity.Internal.Updateable @@ -191,7 +188,7 @@ , async >=2.2 && <3 , base >=4.13 && <5 , bytestring >=0.10 && <0.12 - , calamity-commands ==0.3.* + , calamity-commands ==0.4.* , colour >=2.3.5 && <2.4 , concurrent-extra ==0.7.* , connection >=0.2.6 && <0.4 @@ -205,14 +202,11 @@ , di-polysemy ==0.2.* , exceptions ==0.10.* , focus >=1.0 && <2 - , generic-lens >=2.0 && <3 , hashable >=1.2 && <2 , http-api-data >=0.4.3 && <0.5 , http-client >=0.5 && <0.8 , http-date >=0.0.8 && <0.1 , http-types ==0.12.* - , lens >=5.1 && <6 - , lens-aeson >=1.1.2 && <2 , megaparsec >=8 && <10 , mime-types ==0.1.* , mtl >=2.2 && <3 @@ -226,8 +220,6 @@ , stm-chans >=3.0 && <4 , stm-containers >=1.1 && <2 , text >=1.2 && <2.1 - -- text 2.0 usage is blocked on generics lens, - -- it can be jailbroken by end users however , text-show >=3.8 && <4 , time >=1.8 && <1.13 , tls >=1.4 && <2 @@ -239,4 +231,6 @@ , websockets >=0.12 && <0.13 , x509-system >=1.6.6 && <1.7 , random >=1.2 && <1.3 + , optics >=0.4.1 && <0.5 + , aeson-optics >=1.2 && <2 default-language: Haskell2010