diff --git a/Calamity.hs b/Calamity.hs --- a/Calamity.hs +++ b/Calamity.hs @@ -1,12 +1,13 @@ -module Calamity - ( module Calamity.Client - , module Calamity.HTTP - , module Calamity.Types - , module Calamity.Utils - , module Calamity.Gateway.Intents ) where +module Calamity ( + module Calamity.Client, + module Calamity.HTTP, + module Calamity.Types, + module Calamity.Utils, + module Calamity.Gateway.Intents, +) where -import Calamity.Client -import Calamity.Gateway.Intents -import Calamity.HTTP -import Calamity.Types -import Calamity.Utils +import Calamity.Client +import Calamity.Gateway.Intents +import Calamity.HTTP +import Calamity.Types +import Calamity.Utils diff --git a/Calamity/Cache/Eff.hs b/Calamity/Cache/Eff.hs --- a/Calamity/Cache/Eff.hs +++ b/Calamity/Cache/Eff.hs @@ -1,55 +1,55 @@ {-# LANGUAGE TemplateHaskell #-} -- | Effect for handling the cache -module Calamity.Cache.Eff - ( CacheEff(..) - , setBotUser - , updateBotUser - , getBotUser - , setGuild - , updateGuild - , getGuild - , getGuildChannel - , getGuilds - , delGuild - , setDM - , updateDM - , getDM - , getDMs - , delDM - -- , setGuildChannel - -- , getGuildChannel - -- , delGuildChannel - , setUser - , updateUser - , getUser - , getUsers - , delUser - , setUnavailableGuild - , isUnavailableGuild - , getUnavailableGuilds - , delUnavailableGuild - , setMessage - , updateMessage - , getMessage - , getMessages - , delMessage ) where +module Calamity.Cache.Eff ( + CacheEff (..), + setBotUser, + updateBotUser, + getBotUser, + setGuild, + updateGuild, + getGuild, + getGuildChannel, + getGuilds, + delGuild, + setDM, + updateDM, + getDM, + getDMs, + delDM, + -- , setGuildChannel + -- , getGuildChannel + -- , delGuildChannel + setUser, + updateUser, + getUser, + getUsers, + delUser, + setUnavailableGuild, + isUnavailableGuild, + getUnavailableGuilds, + delUnavailableGuild, + setMessage, + updateMessage, + getMessage, + getMessages, + delMessage, +) where -import Calamity.Internal.Utils -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Polysemy -import qualified Polysemy as P +import Polysemy +import Polysemy qualified as P data CacheEff m a where -- | Set the 'User' representing the bot itself SetBotUser :: User -> CacheEff m () -- | Get the 'User' representing the bot itself GetBotUser :: CacheEff m (Maybe User) - -- | Set or Update a 'Guild' in the cache SetGuild :: Guild -> CacheEff m () -- | Get a 'Guild' from the cache @@ -60,7 +60,6 @@ GetGuilds :: CacheEff m [Guild] -- | Delete a 'Guild' from the cache DelGuild :: Snowflake Guild -> CacheEff m () - -- | Set or Update a 'DMChannel' in the cache SetDM :: DMChannel -> CacheEff m () -- | Get a 'DMChannel' from the cache @@ -69,13 +68,13 @@ GetDMs :: CacheEff m [DMChannel] -- | Delete a 'DMChannel' from the cache DelDM :: Snowflake DMChannel -> CacheEff m () - -- -- | Set or Update a 'GuildChannel' in the cache -- SetGuildChannel :: GuildChannel -> CacheEff m () -- -- | Get a 'GuildChannel' from the cache -- GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel) -- -- | Delete a 'GuildChannel' from the cache -- DelGuildChannel :: Snowflake GuildChannel -> CacheEff m () + -- | Set or Update a 'User' in the cache SetUser :: User -> CacheEff m () -- | Get a 'User' from the cache @@ -84,7 +83,6 @@ GetUsers :: CacheEff m [User] -- | Delete a 'User' from the cache DelUser :: Snowflake User -> CacheEff m () - -- | Flag a 'Guild' as unavailable SetUnavailableGuild :: Snowflake Guild -> CacheEff m () -- | Test if a 'Guild' is flagged as unavailable @@ -93,7 +91,6 @@ GetUnavailableGuilds :: CacheEff m [Snowflake Guild] -- | Unflag a 'Guild' from being unavailable DelUnavailableGuild :: Snowflake Guild -> CacheEff m () - -- | Add or Update a 'Message' in the cache SetMessage :: Message -> CacheEff m () -- | Get a 'Message' from the cache diff --git a/Calamity/Cache/InMemory.hs b/Calamity/Cache/InMemory.hs --- a/Calamity/Cache/InMemory.hs +++ b/Calamity/Cache/InMemory.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | A 'Cache' handler that operates in memory module Calamity.Cache.InMemory ( @@ -8,24 +9,24 @@ ) where import Calamity.Cache.Eff -import qualified Calamity.Internal.BoundedStore as BS -import qualified Calamity.Internal.SnowflakeMap as SM +import Calamity.Internal.BoundedStore qualified as BS +import Calamity.Internal.SnowflakeMap qualified as SM import Calamity.Internal.Utils import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake 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.Functor.Identity +import Data.HashMap.Strict qualified as SH +import Data.HashSet qualified as HS import Data.IORef import Optics -import qualified Polysemy as P -import qualified Polysemy.AtomicState as P -import Optics.State.Operators ((?=), (%=)) +import Optics.State.Operators ((%=), (?=)) +import Polysemy qualified as P +import Polysemy.AtomicState qualified as P data Cache f = Cache { user :: Maybe User @@ -96,7 +97,7 @@ 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))) + #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 diff --git a/Calamity/Client.hs b/Calamity/Client.hs --- a/Calamity/Client.hs +++ b/Calamity/Client.hs @@ -1,44 +1,46 @@ -- | Module containing the core client stuff -module Calamity.Client - ( module Calamity.Client.Client - , module Calamity.Client.Types - -- * Client stuff - -- $clientDocs - ) where +module Calamity.Client ( + module Calamity.Client.Client, + module Calamity.Client.Types, -import Calamity.Client.Client -import Calamity.Client.Types + -- * Client stuff + -- $clientDocs +) where --- $clientDocs --- --- This module provides the core components for running a discord client, along --- with abstractions for registering event handlers, firing custom events, and --- waiting on events. --- --- --- ==== Registered Metrics --- --- 1. Counter: @"events_recieved" [type, shard]@ --- --- Incremented for each event received, the @type@ parameter is the type --- of event (the name of the constructor in --- 'Calamity.Gateway.DispatchEvents.DispatchData'), and @shard@ is the --- ID of the shard that received the event. --- --- 2. Histogram: @"cache_update"@ --- --- Tracks how long it takes to update the cache after recieving an event. --- --- 3. Histogram: @"event_handle"@ --- --- Tracks how long it takes to process an event handler for an event. --- --- --- ==== Examples --- --- A simple client that prints every message recieved: --- --- @ --- 'Control.Monad.void' . 'Polysemy.runFinal' . 'Polysemy.embedToFinal' . 'Calamity.Cache.InMemory.runCacheInMemory' . 'Calamity.Metrics.Noop.runMetricsNoop' $ 'runBotIO' ('Calamity.Types.Token.BotToken' token) $ do --- 'react' \@\''MessageCreateEvt' $ \\msg -> 'Polysemy.embed' $ 'print' msg --- @ +import Calamity.Client.Client +import Calamity.Client.Types + +{- $clientDocs + + This module provides the core components for running a discord client, along + with abstractions for registering event handlers, firing custom events, and + waiting on events. + + + ==== Registered Metrics + + 1. Counter: @"events_recieved" [type, shard]@ + + Incremented for each event received, the @type@ parameter is the type + of event (the name of the constructor in + 'Calamity.Gateway.DispatchEvents.DispatchData'), and @shard@ is the + ID of the shard that received the event. + + 2. Histogram: @"cache_update"@ + + Tracks how long it takes to update the cache after recieving an event. + + 3. Histogram: @"event_handle"@ + + Tracks how long it takes to process an event handler for an event. + + + ==== Examples + + A simple client that prints every message recieved: + + @ + 'Control.Monad.void' . 'Polysemy.runFinal' . 'Polysemy.embedToFinal' . 'Calamity.Cache.InMemory.runCacheInMemory' . 'Calamity.Metrics.Noop.runMetricsNoop' $ 'runBotIO' ('Calamity.Types.Token.BotToken' token) $ do + 'react' \@\''MessageCreateEvt' $ \\msg -> 'Polysemy.embed' $ 'print' msg + @ +-} diff --git a/Calamity/Client/Client.hs b/Calamity/Client/Client.hs --- a/Calamity/Client/Client.hs +++ b/Calamity/Client/Client.hs @@ -25,7 +25,7 @@ import Calamity.HTTP.Internal.Ratelimit import Calamity.Internal.ConstructorName import Calamity.Internal.RunIntoIO -import qualified Calamity.Internal.SnowflakeMap as SM +import Calamity.Internal.SnowflakeMap qualified as SM import Calamity.Internal.UnixTimestamp import Calamity.Internal.Updateable import Calamity.Internal.Utils @@ -35,7 +35,7 @@ import Calamity.Types.Model.Guild import Calamity.Types.Model.Presence (Presence (..)) import Calamity.Types.Model.User -import qualified Calamity.Types.Model.Voice as V +import Calamity.Types.Model.Voice qualified as V import Calamity.Types.Snowflake import Calamity.Types.Token import Calamity.Types.TokenEff @@ -50,20 +50,19 @@ import Data.IORef import Data.Maybe import Data.Proxy -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time.Clock.POSIX -import qualified Df1 -import qualified Di.Core as DC -import qualified DiPolysemy as Di +import Df1 qualified +import Di.Core qualified as DC +import DiPolysemy qualified as Di import Optics -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.AtomicState as P -import qualified Polysemy.Error as P -import qualified Polysemy.Fail as P -import qualified Polysemy.Reader as P -import qualified Polysemy.Resource as P -import PyF +import Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.AtomicState qualified as P +import Polysemy.Error qualified as P +import Polysemy.Fail qualified as P +import Polysemy.Reader qualified as P +import Polysemy.Resource qualified as P import TextShow (TextShow (showt)) timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) @@ -663,6 +662,9 @@ handleEvent' eh evt@(InteractionCreate interaction) = do updateCache evt pure $ map ($ interaction) (getEventHandlers @'InteractionEvt eh) +handleEvent' _ (UNHANDLED e) = do + debug . T.pack $ "Not handling event: " <> show e + pure [] handleEvent' _ e = fail $ "Unhandled event: " <> show e updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r () @@ -771,12 +773,14 @@ -- we don't update the cache from interactions -- TODO: should we? updateCache (InteractionCreate _) = pure () +updateCache (UNHANDLED _) = pure () updateReactionAdd :: Bool -> RawEmoji -> Reaction -> Reaction updateReactionAdd isMe emoji reaction = if emoji == reaction ^. #emoji then - reaction & #count %~ succ + reaction + & #count %~ succ & #me %~ (|| isMe) else reaction @@ -784,6 +788,7 @@ updateReactionRemove isMe emoji reaction = if emoji == reaction ^. #emoji then - reaction & #count %~ pred + 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 @@ -8,14 +8,13 @@ import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Monad -import qualified Data.Text as T +import Data.Text qualified as T import Data.Traversable import Optics import Polysemy (Sem) -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified Polysemy.Reader as P -import PyF +import Polysemy qualified as P +import Polysemy.Fail qualified as P +import Polysemy.Reader qualified as P mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f (Left a) = Left $ f a diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs --- a/Calamity/Client/Types.hs +++ b/Calamity/Client/Types.hs @@ -45,17 +45,17 @@ import Data.Maybe import Data.Time import Data.TypeRepMap (TypeRepMap, WrapTypeable (..)) -import qualified Data.TypeRepMap as TM +import Data.TypeRepMap qualified as TM import Data.Typeable import Data.Void (Void) -import qualified Df1 -import qualified Di.Core as DC +import Df1 qualified +import Di.Core qualified as DC import GHC.Exts (fromList) 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 Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.AtomicState qualified as P +import Polysemy.Reader qualified as P data Client = Client { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))] @@ -227,7 +227,7 @@ EHType 'UserUpdateEvt = (User, User) EHType 'VoiceStateUpdateEvt = (Maybe VoiceState, VoiceState) EHType 'InteractionEvt = Interaction - EHType ( 'CustomEvt a) = a + EHType ('CustomEvt a) = a type StoredEHType t = EHType t -> IO () @@ -244,7 +244,7 @@ deriving newtype (Monoid, Semigroup) type family EHStorageType (t :: EventType) where - EHStorageType ( 'CustomEvt _) = TypeRepMap CustomEHTypeStorage + EHStorageType ('CustomEvt _) = TypeRepMap CustomEHTypeStorage EHStorageType t = [EventHandlerWithID (StoredEHType t)] newtype EventHandler (t :: EventType) = EH @@ -290,7 +290,7 @@ , WrapTypeable $ EH @'TypingStartEvt [] , WrapTypeable $ EH @'UserUpdateEvt [] , WrapTypeable $ EH @'InteractionEvt [] - , WrapTypeable $ EH @( 'CustomEvt Void) TM.empty + , WrapTypeable $ EH @('CustomEvt Void) TM.empty ] instance Semigroup EventHandlers where @@ -302,7 +302,7 @@ -- not sure what to think of this type family EHInstanceSelector (d :: EventType) :: Bool where - EHInstanceSelector ( 'CustomEvt _) = 'True + EHInstanceSelector ('CustomEvt _) = 'True EHInstanceSelector _ = 'False {- | A helper typeclass that is used to decide how to register regular @@ -317,10 +317,10 @@ class InsertEventHandler' (flag :: Bool) a where makeEventHandlers' :: Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers -instance forall (x :: Type). (Typeable (EHType ( 'CustomEvt x))) => InsertEventHandler' 'True ( 'CustomEvt x) where +instance forall (x :: Type). (Typeable (EHType ('CustomEvt x))) => InsertEventHandler' 'True ('CustomEvt x) where makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ - EH @( 'CustomEvt Void) + EH @('CustomEvt Void) (TM.one @x $ CustomEHTypeStorage [EventHandlerWithID id' handler]) instance (Typeable s, EHStorageType s ~ [EventHandlerWithID (StoredEHType s)], Typeable (StoredEHType s)) => InsertEventHandler' 'False s where @@ -335,7 +335,7 @@ class GetEventHandlers' (flag :: Bool) a where getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a] -instance GetEventHandlers' 'True ( 'CustomEvt a) where +instance GetEventHandlers' 'True ('CustomEvt a) where getEventHandlers' _ _ _ = error "use getCustomEventHandlers instead" instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where @@ -352,10 +352,10 @@ class RemoveEventHandler' (flag :: Bool) a where removeEventHandler' :: Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers -instance forall (a :: Type). (Typeable a) => RemoveEventHandler' 'True ( 'CustomEvt a) where +instance forall (a :: Type). (Typeable a) => RemoveEventHandler' 'True ('CustomEvt a) where removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ - TM.adjust @( 'CustomEvt Void) + TM.adjust @('CustomEvt Void) ( \(EH ehs) -> EH ( TM.adjust @a @@ -378,8 +378,8 @@ getCustomEventHandlers :: forall a. Typeable a => EventHandlers -> [a -> IO ()] getCustomEventHandlers (EventHandlers handlers) = let handlerMap = - unwrapEventHandler @( 'CustomEvt Void) $ - fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler ( 'CustomEvt Void))) + 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.hs b/Calamity/Commands.hs --- a/Calamity/Commands.hs +++ b/Calamity/Commands.hs @@ -2,22 +2,22 @@ This module exports the DSL and core types for using commands -} module Calamity.Commands ( - module Calamity.Commands.Dsl, - module CalamityCommands.Error, - module Calamity.Commands.Help, - module CalamityCommands.Parser, - module Calamity.Commands.Utils, - module Calamity.Commands.Types, + module Calamity.Commands.Dsl, + module CalamityCommands.Error, + module Calamity.Commands.Help, + module CalamityCommands.Parser, + module Calamity.Commands.Utils, + module Calamity.Commands.Types, - -- * Commands - -- $commandDocs + -- * Commands + -- $commandDocs ) where import Calamity.Commands.CalamityParsers () import Calamity.Commands.Dsl import Calamity.Commands.Help -import Calamity.Commands.Utils import Calamity.Commands.Types +import Calamity.Commands.Utils import CalamityCommands.Error import CalamityCommands.Parser diff --git a/Calamity/Commands/CalamityParsers.hs b/Calamity/Commands/CalamityParsers.hs --- a/Calamity/Commands/CalamityParsers.hs +++ b/Calamity/Commands/CalamityParsers.hs @@ -12,14 +12,14 @@ import Calamity.Types.Snowflake import CalamityCommands.ParameterInfo import CalamityCommands.Parser -import Optics import Control.Monad import Control.Monad.Trans (lift) import Data.Maybe (fromMaybe, isJust) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Typeable -import qualified Polysemy as P -import qualified Polysemy.Reader as P +import Optics +import Polysemy qualified as P +import Polysemy.Reader qualified as P import Text.Megaparsec hiding (parse) import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Error.Builder (errFancy, fancy) @@ -147,8 +147,8 @@ -- | Parses both discord emojis, and unicode emojis instance ParameterParser RawEmoji c r where parse = parseMP (parserName @RawEmoji) (try parseCustomEmoji <|> UnicodeEmoji <$> takeP (Just "A unicode emoji") 1) - where - parseCustomEmoji = CustomEmoji <$> partialEmoji + where + parseCustomEmoji = CustomEmoji <$> partialEmoji parameterDescription = "emoji" {- | ParameterParser for roles in the guild the command was invoked in, this only diff --git a/Calamity/Commands/Context.hs b/Calamity/Commands/Context.hs --- a/Calamity/Commands/Context.hs +++ b/Calamity/Commands/Context.hs @@ -17,14 +17,14 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Calamity.Types.Tellable -import qualified CalamityCommands.Context as CC +import CalamityCommands.Context qualified as CC import Control.Applicative import Control.Monad -import qualified Data.Text as T +import Data.Text qualified as T import Optics -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified TextShow +import Polysemy qualified as P +import Polysemy.Fail qualified as P +import TextShow qualified class CommandContext c => CalamityCommandContext c where -- | The id of the channel that invoked this command @@ -41,25 +41,25 @@ -- | Invokation context for commands data FullContext = FullContext - { -- | The message that the command was invoked from - message :: Message - , -- | If the command was sent in a guild, this will be present - guild :: Maybe Guild - , -- | The member that invoked the command, if in a guild - -- - -- Note: If discord sent a member with the message, this is used; otherwise - -- we try to fetch the member from the cache. - member :: Maybe Member - , -- | The channel the command was invoked from - channel :: Channel - , -- | The user that invoked the command - user :: User - , -- | The command that was invoked - command :: Command FullContext - , -- | The prefix that was used to invoke the command - prefix :: T.Text - , -- | The message remaining after consuming the prefix - unparsedParams :: T.Text + { message :: Message + -- ^ The message that the command was invoked from + , guild :: Maybe Guild + -- ^ If the command was sent in a guild, this will be present + , member :: Maybe Member + -- ^ The member that invoked the command, if in a guild + -- + -- Note: If discord sent a member with the message, this is used; otherwise + -- we try to fetch the member from the cache. + , channel :: Channel + -- ^ The channel the command was invoked from + , user :: User + -- ^ The user that invoked the command + , command :: Command FullContext + -- ^ The command that was invoked + , prefix :: T.Text + -- ^ The prefix that was used to invoke the command + , unparsedParams :: T.Text + -- ^ The message remaining after consuming the prefix } deriving (Show) deriving (TextShow.TextShow) via TextShow.FromStringShow FullContext @@ -103,24 +103,24 @@ -- | A lightweight context that doesn't need any cache information data LightContext = LightContext - { -- | The message that the command was invoked from - message :: Message - , -- | If the command was sent in a guild, this will be present - guildID :: Maybe (Snowflake Guild) - , -- | The channel the command was invoked from - channelID :: Snowflake Channel - , -- | The user that invoked the command - user :: User - , -- | The member that triggered the command. - -- - -- Note: Only sent if discord sent the member object with the message. - member :: Maybe Member - , -- | The command that was invoked - command :: Command LightContext - , -- | The prefix that was used to invoke the command - prefix :: T.Text - , -- | The message remaining after consuming the prefix - unparsedParams :: T.Text + { message :: Message + -- ^ The message that the command was invoked from + , guildID :: Maybe (Snowflake Guild) + -- ^ If the command was sent in a guild, this will be present + , channelID :: Snowflake Channel + -- ^ The channel the command was invoked from + , user :: User + -- ^ The user that invoked the command + , member :: Maybe Member + -- ^ The member that triggered the command. + -- + -- Note: Only sent if discord sent the member object with the message. + , command :: Command LightContext + -- ^ The command that was invoked + , prefix :: T.Text + -- ^ The prefix that was used to invoke the command + , unparsedParams :: T.Text + -- ^ The message remaining after consuming the prefix } deriving (Show) deriving (TextShow.TextShow) via TextShow.FromStringShow LightContext diff --git a/Calamity/Commands/Dsl.hs b/Calamity/Commands/Dsl.hs --- a/Calamity/Commands/Dsl.hs +++ b/Calamity/Commands/Dsl.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecursiveDo #-} - {- | A DSL for generating commands and groups This is effectively just a re-export of "CalamityCommands.Dsl" but with @@ -25,20 +23,20 @@ fetchHandler, ) where -import qualified CalamityCommands.Dsl as CC +import CalamityCommands.Dsl qualified as CC import CalamityCommands.ParameterInfo import Calamity.Commands.Types -import qualified Data.Text as T +import Data.Text qualified as T import CalamityCommands.CommandUtils (CommandForParsers, TypedCommandC) -import qualified CalamityCommands.Context as CC +import CalamityCommands.Context qualified as CC import CalamityCommands.Error (CommandError) -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified Polysemy.Reader as P -import qualified Polysemy.Tagged as P +import Polysemy qualified as P +import Polysemy.Fail qualified as P +import Polysemy.Reader qualified as P +import Polysemy.Tagged qualified as P {- $dslTutorial diff --git a/Calamity/Commands/Help.hs b/Calamity/Commands/Help.hs --- a/Calamity/Commands/Help.hs +++ b/Calamity/Commands/Help.hs @@ -7,9 +7,9 @@ import Calamity.Client.Types (BotC) import Calamity.Commands.Types import Calamity.Types.Tellable -import qualified CalamityCommands.Help as CC +import CalamityCommands.Help qualified as CC import Control.Monad (void) -import qualified Polysemy as P +import Polysemy qualified as P {- | Given a 'CommandHandler', optionally a parent 'Group', and a list of 'Check's, construct a help command that will provide help for all the commands and diff --git a/Calamity/Commands/Types.hs b/Calamity/Commands/Types.hs --- a/Calamity/Commands/Types.hs +++ b/Calamity/Commands/Types.hs @@ -4,21 +4,21 @@ the more generic variants. -} module Calamity.Commands.Types ( - type Command, - type Group, - type CommandHandler, - type Check, - type DSLState, - type DSLC, - type CommandContext, + type Command, + type Group, + type CommandHandler, + type Check, + type DSLState, + type DSLC, + type CommandContext, ) where -import qualified CalamityCommands.Check as CC -import qualified CalamityCommands.Command as CC -import qualified CalamityCommands.Dsl as CC -import qualified CalamityCommands.Group as CC -import qualified CalamityCommands.Handler as CC -import qualified CalamityCommands.Context as CC +import CalamityCommands.Check qualified as CC +import CalamityCommands.Command qualified as CC +import CalamityCommands.Context qualified as CC +import CalamityCommands.Dsl qualified as CC +import CalamityCommands.Group qualified as CC +import CalamityCommands.Handler qualified as CC type Command c = CC.Command IO c () type Group c = CC.Group IO c () diff --git a/Calamity/Commands/Utils.hs b/Calamity/Commands/Utils.hs --- a/Calamity/Commands/Utils.hs +++ b/Calamity/Commands/Utils.hs @@ -19,15 +19,15 @@ import Calamity.Types.Model.Guild.Member (Member) import Calamity.Types.Model.User (User) import CalamityCommands.CommandUtils -import qualified CalamityCommands.Context as CC -import qualified CalamityCommands.Error as CC -import qualified CalamityCommands.ParsePrefix as CC -import qualified CalamityCommands.Utils as CC +import CalamityCommands.Context qualified as CC +import CalamityCommands.Error qualified as CC +import CalamityCommands.ParsePrefix qualified as CC +import CalamityCommands.Utils qualified as CC import Control.Monad -import qualified Data.Text as T +import Data.Text qualified as T import Data.Typeable -import qualified Polysemy as P import Optics.TH (makeFieldLabelsNoPrefix) +import Polysemy qualified as P data CmdInvokeFailReason c = NoContext @@ -44,8 +44,8 @@ { msg :: Message , user :: User , member :: Maybe Member - , -- | The groups that were successfully parsed - path :: [T.Text] + , path :: [T.Text] + -- ^ The groups that were successfully parsed } deriving (Show) @@ -56,44 +56,49 @@ -- | 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 -useConstantPrefix pre = P.interpret (\case - CC.ParsePrefix Message { content } -> pure ((pre, ) <$> T.stripPrefix pre content)) +useConstantPrefix pre = + P.interpret + ( \case + CC.ParsePrefix Message {content} -> pure ((pre,) <$> T.stripPrefix pre content) + ) --- | Construct commands and groups from a command DSL, then registers an event --- handler on the bot that manages running those commands. --- --- --- Returns an action to remove the event handler, and the 'CommandHandler' that was constructed. --- --- ==== Command Resolution --- --- To determine if a command was invoked, and if so which command was invoked, the following happens: --- --- 1. 'CalamityCommands.ParsePrefix.parsePrefix' is invoked, if no prefix is found: stop here. --- --- 2. The input is read a word at a time until a matching command is found, --- fire the \"command-not-found\" event if not. --- --- 3. A 'Calamity.Commands.Context.Context' is built, and the command invoked. --- --- ==== Custom Events --- --- This will fire the following events: --- --- 1. 'CtxCommandError' --- --- Fired when a command returns an error. --- --- 2. 'CommandNotFound' --- --- Fired when a valid prefix is used, but the command is not found. --- --- 3. 'CommandInvoked' --- --- Fired when a command is successfully invoked. --- -addCommands :: (BotC r, Typeable c, CommandContext c, P.Members [CC.ParsePrefix Message, CC.ConstructContext (Message, User, Maybe Member) c IO ()] r) - => P.Sem (DSLState c r) a -> P.Sem r (P.Sem r (), CommandHandler c, a) +{- | Construct commands and groups from a command DSL, then registers an event + handler on the bot that manages running those commands. + + + Returns an action to remove the event handler, and the 'CommandHandler' that was constructed. + + ==== Command Resolution + + To determine if a command was invoked, and if so which command was invoked, the following happens: + + 1. 'CalamityCommands.ParsePrefix.parsePrefix' is invoked, if no prefix is found: stop here. + + 2. The input is read a word at a time until a matching command is found, + fire the \"command-not-found\" event if not. + + 3. A 'Calamity.Commands.Context.Context' is built, and the command invoked. + + ==== Custom Events + + This will fire the following events: + + 1. 'CtxCommandError' + + Fired when a command returns an error. + + 2. 'CommandNotFound' + + Fired when a valid prefix is used, but the command is not found. + + 3. 'CommandInvoked' + + Fired when a command is successfully invoked. +-} +addCommands :: + (BotC r, Typeable c, CommandContext c, P.Members [CC.ParsePrefix Message, CC.ConstructContext (Message, User, Maybe Member) c IO ()] r) => + P.Sem (DSLState c r) a -> + P.Sem r (P.Sem r (), CommandHandler c, a) addCommands m = do (handler, res) <- CC.buildCommands m remove <- react @'MessageCreateEvt $ \case @@ -103,13 +108,12 @@ r <- CC.handleCommands handler (msg, user, member) prefix cmd case r of Left (CC.CommandInvokeError ctx e) -> fire . customEvt $ CtxCommandError ctx e - Left (CC.NotFound path) -> fire . customEvt $ CommandNotFound msg user member path - Left CC.NoContext -> pure () -- ignore if context couldn't be built - Right (ctx, ()) -> do + Left (CC.NotFound path) -> fire . customEvt $ CommandNotFound msg user member path + Left CC.NoContext -> pure () -- ignore if context couldn't be built + Right (ctx, ()) -> do cmdInvoke <- registerCounter "commands_invoked" [("name", T.unwords $ commandPath (CC.ctxCommand ctx))] void $ addCounter 1 cmdInvoke fire . customEvt $ CommandInvoked ctx - Nothing -> pure () _ -> pure () pure (remove, handler, res) diff --git a/Calamity/Gateway.hs b/Calamity/Gateway.hs --- a/Calamity/Gateway.hs +++ b/Calamity/Gateway.hs @@ -1,23 +1,24 @@ --- | -module Calamity.Gateway - ( module Calamity.Gateway.Shard - , module Calamity.Gateway.Types - , module Calamity.Gateway.Intents - -- * Gateway - -- $gatewayDocs - ) where +module Calamity.Gateway ( + module Calamity.Gateway.Shard, + module Calamity.Gateway.Types, + module Calamity.Gateway.Intents, -import Calamity.Gateway.Shard -import Calamity.Gateway.Types -import Calamity.Gateway.Intents + -- * Gateway + -- $gatewayDocs +) where --- $gatewayDocs --- --- This module contains all the gateway related things. --- --- --- ==== Registered Metrics --- --- 1. Gauge: @"active_shards"@ --- --- Keeps track of how many shards are currently active. +import Calamity.Gateway.Intents +import Calamity.Gateway.Shard +import Calamity.Gateway.Types + +{- $gatewayDocs + + This module contains all the gateway related things. + + + ==== Registered Metrics + + 1. Gauge: @"active_shards"@ + + Keeps track of how many shards are currently active. +-} diff --git a/Calamity/Gateway/DispatchEvents.hs b/Calamity/Gateway/DispatchEvents.hs --- a/Calamity/Gateway/DispatchEvents.hs +++ b/Calamity/Gateway/DispatchEvents.hs @@ -20,7 +20,7 @@ import Calamity.Types.Model.Voice import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Kind (Type) import Data.Text (Text) import Data.Time @@ -75,6 +75,7 @@ | VoiceServerUpdate !VoiceServerUpdateData | WebhooksUpdate !WebhooksUpdateData | InteractionCreate !Interaction + | UNHANDLED Text deriving (Show, Generic, CtorName) data ReadyData = ReadyData diff --git a/Calamity/Gateway/Intents.hs b/Calamity/Gateway/Intents.hs --- a/Calamity/Gateway/Intents.hs +++ b/Calamity/Gateway/Intents.hs @@ -3,23 +3,23 @@ -- | Discord gateway intents module Calamity.Gateway.Intents ( - Intents (..), - defaultIntents, - intentGuilds, - intentGuildMembers, - intentGuildBans, - intentGuildEmojis, - intentGuildIntegrations, - intentGuildWebhooks, - intentGuildInvites, - intentGuildVoiceStates, - intentGuildPresences, - intentGuildMessages, - intentGuildMessageReactions, - intentGuildMessageTyping, - intentDirectMessages, - intentDirectMessageReactions, - intentDirectMessageTyping, + Intents (..), + defaultIntents, + intentGuilds, + intentGuildMembers, + intentGuildBans, + intentGuildEmojis, + intentGuildIntegrations, + intentGuildWebhooks, + intentGuildInvites, + intentGuildVoiceStates, + intentGuildPresences, + intentGuildMessages, + intentGuildMessageReactions, + intentGuildMessageTyping, + intentDirectMessages, + intentDirectMessageReactions, + intentDirectMessageTyping, ) where import Data.Aeson (ToJSON) @@ -60,4 +60,4 @@ -- | Default intents are all but the privileged intents: members and intents instance Default Intents where - def = defaultIntents + def = defaultIntents diff --git a/Calamity/Gateway/Shard.hs b/Calamity/Gateway/Shard.hs --- a/Calamity/Gateway/Shard.hs +++ b/Calamity/Gateway/Shard.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} - -- | The shard logic module Calamity.Gateway.Shard ( Shard (..), @@ -63,7 +60,7 @@ 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.Chan.Unagi qualified as UC import Control.Concurrent.STM (STM, atomically, retry) import Control.Concurrent.STM.TBMQueue ( TBMQueue, @@ -77,21 +74,19 @@ Exception (fromException), SomeException, ) -import qualified Control.Exception.Safe as Ex -import Optics -import Optics.State.Operators +import Control.Exception.Safe qualified as Ex 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.Aeson qualified as A +import Data.ByteString.Lazy qualified as LBS import Data.Default.Class (def) import Data.IORef (newIORef) import Data.Maybe (fromMaybe) -import qualified Data.Text as T +import Data.Text qualified as T import DiPolysemy (attr, push) -import qualified Network.Connection as NC -import qualified Network.TLS as NT -import qualified Network.TLS.Extra as NT +import Network.Connection qualified as NC +import Network.TLS qualified as NT +import Network.TLS.Extra qualified as NT import Network.WebSockets ( Connection, ConnectionException (..), @@ -99,16 +94,17 @@ sendCloseCode, sendTextData, ) -import qualified Network.WebSockets as NW -import qualified Network.WebSockets.Stream as NW +import Network.WebSockets qualified as NW +import Network.WebSockets.Stream qualified as NW +import Optics +import Optics.State.Operators import Polysemy (Sem) -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.AtomicState as P -import qualified Polysemy.Error as P -import qualified Polysemy.Resource as P -import PyF (fmt) -import qualified System.X509 as X509 +import Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.AtomicState qualified as P +import Polysemy.Error qualified as P +import Polysemy.Resource qualified as P +import System.X509 qualified as X509 import TextShow (showt) import Prelude hiding (error) @@ -226,7 +222,7 @@ handleWSException e = pure $ case fromException e of Just (CloseRequest code _) | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] -> - Left (ShutDownShard, Just . showt $ code) + 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 () @@ -246,7 +242,7 @@ Right a -> P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) Left e -> do - error . T.pack $ "Failed to decode " <> e <> ": "<> show msg' + error . T.pack $ "Failed to decode " <> e <> ": " <> show msg' pure True when r inner outerloop :: ShardC r => Sem r () @@ -307,7 +303,7 @@ , compress = False , largeThreshold = Nothing , shard = - Just ( shard ^. #shardID , shard ^. #shardCount ) + Just (shard ^. #shardID, shard ^. #shardCount) , presence = shard ^. #initialStatus , intents = shard ^. #intents } diff --git a/Calamity/Gateway/Types.hs b/Calamity/Gateway/Types.hs --- a/Calamity/Gateway/Types.hs +++ b/Calamity/Gateway/Types.hs @@ -30,17 +30,18 @@ import Calamity.Types.Snowflake import Control.Concurrent.Async import Control.Concurrent.Chan.Unagi -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Aeson.Optics import Data.Aeson.Types (parseMaybe) -import qualified Data.Aeson.Types as AT +import Data.Aeson.Types qualified as AT import Data.Text (Text) +import Data.Text qualified as T 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 +import Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.AtomicState qualified as P type ShardC r = ( P.Members @@ -149,6 +150,7 @@ 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' +parseDispatchData e _ = pure . UNHANDLED . T.pack . show $ e data SentDiscordMessage = StatusUpdate StatusUpdateData @@ -179,16 +181,29 @@ data DispatchType = READY | RESUMED + | APPLICATION_COMMAND_PERMISSIONS_UPDATE + | AUTO_MODERATION_RULE_CREATE + | AUTO_MODERATION_RULE_UPDATE + | AUTO_MODERATION_RULE_DELETE + | AUTO_MODERATION_ACTION_EXECUTION | CHANNEL_CREATE | CHANNEL_UPDATE | CHANNEL_DELETE | CHANNEL_PINS_UPDATE + | THREAD_CREATE + | THREAD_UPDATE + | THREAD_DELETE + | THREAD_LIST_SYNC + | THREAD_MEMBER_UPDATE + | THREAD_MEMBERS_UPDATE | GUILD_CREATE | GUILD_UPDATE | GUILD_DELETE + | GUILD_AUDIT_LOG_ENTRY_CREATE | GUILD_BAN_ADD | GUILD_BAN_REMOVE | GUILD_EMOJIS_UPDATE + | GUILD_STICKERS_UPDATE | GUILD_INTEGRATIONS_UPDATE | GUILD_MEMBER_ADD | GUILD_MEMBER_REMOVE @@ -197,6 +212,15 @@ | GUILD_ROLE_CREATE | GUILD_ROLE_UPDATE | GUILD_ROLE_DELETE + | GUILD_SCHEDULED_EVENT_CREATE + | GUILD_SCHEDULED_EVENT_UPDATE + | GUILD_SCHEDULED_EVENT_DELETE + | GUILD_SCHEDULED_EVENT_USER_ADD + | GUILD_SCHEDULED_EVENT_USER_REMOVE + | INTEGRATION_CREATE + | INTEGRATION_UPDATE + | INTEGRATION_DELETE + | INTERACTION_CREATE | INVITE_CREATE | INVITE_DELETE | MESSAGE_CREATE @@ -206,13 +230,16 @@ | MESSAGE_REACTION_ADD | MESSAGE_REACTION_REMOVE | MESSAGE_REACTION_REMOVE_ALL + | MESSAGE_REACTION_REMOVE_EMOJI | PRESENCE_UPDATE + | STAGE_INSTANCE_CREATE + | STAGE_INSTANCE_UPDATE + | STATE_INSTANCE_DELETE | TYPING_START | USER_UPDATE | VOICE_STATE_UPDATE | VOICE_SERVER_UPDATE | WEBHOOKS_UPDATE - | INTERACTION_CREATE deriving (Show, Eq, Enum, Generic) deriving (Aeson.ToJSON, Aeson.FromJSON) diff --git a/Calamity/HTTP.hs b/Calamity/HTTP.hs --- a/Calamity/HTTP.hs +++ b/Calamity/HTTP.hs @@ -14,6 +14,7 @@ module Calamity.HTTP.Internal.Types, RatelimitEff (..), TokenEff (..), + -- * HTTP -- $httpDocs ) where @@ -33,28 +34,29 @@ import Calamity.HTTP.Webhook import Calamity.Types.TokenEff (TokenEff (..)) --- $httpDocs --- --- This module contains all the http related things --- --- --- ==== Registered Metrics --- --- 1. Gauge: @"inflight_requests" [route]@ --- --- Keeps track of how many requests are currently in-flight, the @route@ --- parameter will be the route that is currently active. --- --- 2. Counter: @"total_requests" [route]@ --- --- Incremented on every request, the @route@ parameter is the route that --- the request was made on. --- --- --- ==== Examples --- --- Editing a message: --- --- @ --- 'invoke' $ 'EditMessage' someChannel someMessage ('Just' "new content") 'Nothing' --- @ +{- $httpDocs + + This module contains all the http related things + + + ==== Registered Metrics + + 1. Gauge: @"inflight_requests" [route]@ + + Keeps track of how many requests are currently in-flight, the @route@ + parameter will be the route that is currently active. + + 2. Counter: @"total_requests" [route]@ + + Incremented on every request, the @route@ parameter is the route that + the request was made on. + + + ==== Examples + + Editing a message: + + @ + 'invoke' $ 'EditMessage' someChannel someMessage ('Just' "new content") 'Nothing' + @ +-} diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs --- a/Calamity/HTTP/Channel.hs +++ b/Calamity/HTTP/Channel.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Channel endpoints module Calamity.HTTP.Channel ( @@ -31,19 +32,18 @@ import Calamity.Types.Model.Guild.Role (Role) import Calamity.Types.Model.User import Calamity.Types.Snowflake -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as K +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as K import Data.ByteString.Lazy (ByteString) import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Word import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime import Optics -import PyF import TextShow data CreateMessageAttachment = CreateMessageAttachment @@ -474,4 +474,3 @@ 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,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Emoji endpoints module Calamity.HTTP.Emoji ( @@ -12,7 +13,7 @@ import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) import Calamity.Types.Model.Guild import Calamity.Types.Snowflake -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Function import Data.Text (Text) import Network.HTTP.Req diff --git a/Calamity/HTTP/Guild.hs b/Calamity/HTTP/Guild.hs --- a/Calamity/HTTP/Guild.hs +++ b/Calamity/HTTP/Guild.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Guild endpoints module Calamity.HTTP.Guild ( @@ -34,8 +35,8 @@ import Calamity.Types.Model.User import Calamity.Types.Model.Voice import Calamity.Types.Snowflake -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as K +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as K import Data.Colour (Colour) import Data.Default.Class import Data.Text (Text) diff --git a/Calamity/HTTP/Interaction.hs b/Calamity/HTTP/Interaction.hs --- a/Calamity/HTTP/Interaction.hs +++ b/Calamity/HTTP/Interaction.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Interaction endpoints module Calamity.HTTP.Interaction ( @@ -18,19 +19,18 @@ import Calamity.Types.Model.Channel.Message (Message) import Calamity.Types.Model.Interaction import Calamity.Types.Snowflake -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Bits (shiftL, (.|.)) import Data.Default.Class -import qualified Data.HashMap.Strict as H +import Data.HashMap.Strict qualified as H import Data.Maybe (fromMaybe) import Data.Monoid (First (First, getFirst)) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime import Optics -import PyF data InteractionCallback = InteractionCallback { type_ :: InteractionCallbackType @@ -110,8 +110,8 @@ data InteractionCallbackAutocompleteChoice = InteractionCallbackAutocompleteChoice { name :: Text , nameLocalizations :: H.HashMap Text Text - , -- | Either text or numeric - value :: Aeson.Value + , value :: Aeson.Value + -- ^ Either text or numeric } deriving stock (Show) deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocompleteChoice 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 @@ -16,16 +16,16 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Event (Event) -import qualified Control.Concurrent.Event as E +import Control.Concurrent.Event qualified as E import Control.Concurrent.STM -import qualified Control.Exception.Safe as Ex +import Control.Exception.Safe qualified as Ex import Control.Monad -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Aeson.Optics -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as LB import Data.Maybe -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time import Data.Time.Clock.POSIX import Network.HTTP.Client (responseStatus) @@ -34,11 +34,10 @@ import Optics import Optics.Operators.Unsafe ((^?!)) import Polysemy (Sem, makeSem) -import qualified Polysemy as P -import PyF -import qualified StmContainers.Map as SC +import Polysemy qualified as P +import StmContainers.Map qualified as SC import Prelude hiding (error) -import qualified Prelude +import Prelude qualified data RatelimitEff m a where GetRatelimitState :: RatelimitEff m RateLimitState @@ -55,7 +54,7 @@ getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit getRateLimit s h = do bucketKey <- SC.lookup h $ bucketKeys s - bucket <- join <$> sequenceA (flip SC.lookup (buckets s) <$> bucketKey) + bucket <- join <$> traverse (`SC.lookup` buckets s) bucketKey case bucket of Just bucket' -> pure $ KnownRatelimit bucket' @@ -79,7 +78,6 @@ else old ^. #resetTime } - updateKnownBucket :: Bucket -> BucketState -> STM () updateKnownBucket bucket bucketState = modifyTVar' (bucket ^. #state) (`mergeBucketStates` bucketState) @@ -119,7 +117,8 @@ modifyTVar' (bucket ^. #state) ( \bs -> - bs & #remaining .~ bs ^. #limit + bs + & #remaining .~ bs ^. #limit & #resetTime .~ Nothing ) @@ -199,14 +198,10 @@ -- if we needed to sleep, go again so that multiple concurrent requests -- don't exceed the bucket, to ensure we don't sit in a loop if a -- request dies on us, bail out after 50 loops - if tries < 50 - then go (tries + 1) - else pure () -- print "bailing after number of retries" + when (tries < 50) $ go (tries + 1) -- print "bailing after number of retries" WaitRetrySoon -> do threadDelayMS 20 - if tries < 50 - then go (tries + 1) - else pure () -- print "bailing after number of retries" + when (tries < 50) $ go (tries + 1) -- print "bailing after number of retries" GoNow -> do -- print "ok going forward with request" pure () @@ -219,26 +214,26 @@ let status = responseStatus . toVanillaResponse $ r' if | statusIsSuccessful status -> do - let resp = responseBody r' - debug $ "Got good response from discord: " <> (T.pack . show $ status) - now <- P.embed getCurrentTime - let rlHeaders = buildBucketState now r' - pure $ Good resp rlHeaders + let resp = responseBody r' + debug $ "Got good response from discord: " <> (T.pack . show $ status) + now <- P.embed getCurrentTime + let rlHeaders = buildBucketState now r' + pure $ Good resp rlHeaders | status == status429 -> do - now <- P.embed getCurrentTime - let resp = responseBody r' - case (resp ^? _Value, buildBucketState now r') of - (Just !rv, bs) -> - pure $ Ratelimited (parseRetryAfter now rv) (isGlobal rv) bs - _ -> - pure $ ServerError (statusCode status) + now <- P.embed getCurrentTime + let resp = responseBody r' + case (resp ^? _Value, buildBucketState now r') of + (Just !rv, bs) -> + pure $ Ratelimited (parseRetryAfter now rv) (isGlobal rv) bs + _ -> + pure $ ServerError (statusCode status) | statusIsClientError status -> do - let err = responseBody r' - error . T.pack $ ("Something went wrong: " <> show err <> ", response: " <> show r') - pure $ ClientError (statusCode status) err + let err = responseBody r' + error . T.pack $ "Something went wrong: " <> show err <> ", response: " <> show r' + pure $ ClientError (statusCode status) err | otherwise -> do - debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status) - pure $ ServerError (statusCode status) + debug . T.pack $ "Got server error from discord: " <> (show . statusCode $ status) + pure $ ServerError (statusCode status) Left e -> do error . T.pack $ "Something went wrong with the http client: " <> e pure . InternalResponseError $ T.pack e @@ -255,8 +250,11 @@ end :: Maybe UTCTime end = - posixSecondsToUTCTime . realToFrac - <$> responseHeader r "X-Ratelimit-Reset" ^? _Just % _Double + posixSecondsToUTCTime + . realToFrac + <$> responseHeader r "X-Ratelimit-Reset" + ^? _Just + % _Double buildBucketState :: HttpResponse r => UTCTime -> r -> Maybe (BucketState, B.ByteString) buildBucketState now r = (,) <$> bs <*> bucketKey @@ -355,7 +353,6 @@ void $ updateBucket rlstate (routeKey route) bk bs (_, Nothing) -> pure () pure $ RGood v - Ratelimited unlockWhen False (Just (bs, bk)) -> do debug . T.pack $ "429 ratelimited on route, retrying at " <> show unlockWhen @@ -370,7 +367,6 @@ threadDelayUntil unlockWhen pure $ Retry (HTTPError 429 Nothing) - Ratelimited unlockWhen False _ -> do debug "Internal error (ratelimited but no headers), retrying" case rl of @@ -380,7 +376,6 @@ P.embed $ threadDelayUntil unlockWhen pure $ Retry (HTTPError 429 Nothing) - Ratelimited unlockWhen True bs -> do debug "429 ratelimited globally" 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 @@ -26,14 +26,14 @@ import Control.Monad import Data.Aeson hiding (Options) import Data.Aeson.Types (parseEither) -import qualified Data.ByteString.Lazy as LB -import qualified Data.Text as T -import qualified Data.Text.Encoding as TS +import Data.ByteString.Lazy qualified as LB +import Data.Text qualified as T +import Data.Text.Encoding qualified 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 Polysemy qualified as P +import Polysemy.Error qualified as P import Web.HttpApiData throwIfLeft :: P.Member (P.Error RestError) r => Either String a -> P.Sem r a 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 @@ -28,14 +28,14 @@ import Data.List (foldl') import Data.Maybe (fromJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified 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 +import TextShow qualified data RouteFragment = -- | Static string fragment @@ -121,9 +121,9 @@ 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 ('Just 'Required) = 'Required + AddRequiredInner ('Just 'Satisfied) = 'Satisfied + AddRequiredInner ('Just 'NotNeeded) = 'Required AddRequiredInner 'Nothing = 'Required class Typeable a => RouteFragmentable a reqs where @@ -138,13 +138,13 @@ 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 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,50 +1,51 @@ {-# LANGUAGE TemplateHaskell #-} -- | Types for the http lib -module Calamity.HTTP.Internal.Types - ( RestError(..) - , RateLimitState(..) - , DiscordResponseType(..) - , Bucket(..) - , BucketState(..) - , GatewayResponse - , BotGatewayResponse ) where +module Calamity.HTTP.Internal.Types ( + RestError (..), + RateLimitState (..), + DiscordResponseType (..), + Bucket (..), + BucketState (..), + GatewayResponse, + BotGatewayResponse, +) where import Calamity.HTTP.Internal.Route -import Control.Concurrent.Event ( Event ) -import Control.Concurrent.STM.TVar ( TVar ) +import Control.Concurrent.Event (Event) +import Control.Concurrent.STM.TVar (TVar) +import Data.Aeson +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as LB +import Data.Text as T import Data.Time -import Data.Aeson -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString as B -import Data.Text as T -import qualified StmContainers.Map as SC -import qualified Data.Aeson as Aeson import Optics.TH +import StmContainers.Map qualified as SC data RestError - -- | An error response from discord - = HTTPError - { status :: Int + = -- | An error response from discord + HTTPError + { status :: Int , response :: Maybe Value } - -- | Something failed while making the request (after retrying a few times) - | InternalClientError T.Text - deriving ( Show) + | -- | Something failed while making the request (after retrying a few times) + InternalClientError T.Text + deriving (Show) data BucketState = BucketState { resetTime :: Maybe UTCTime - -- ^ The time when the bucket resets, used to heuristically wait out ratelimits - , resetKey :: Int - -- ^ The X-Ratelimit-Reset value discord gave us + -- ^ The time when the bucket resets, used to heuristically wait out ratelimits + , resetKey :: Int + -- ^ The X-Ratelimit-Reset value discord gave us , remaining :: Int - -- ^ The number of uses left in the bucket, used to heuristically wait out ratelimits + -- ^ The number of uses left in the bucket, used to heuristically wait out ratelimits , limit :: Int - -- ^ The total number of uses for this bucket + -- ^ The total number of uses for this bucket , ongoing :: Int - -- ^ How many ongoing requests + -- ^ How many ongoing requests } - deriving ( Show ) + deriving (Show) newtype Bucket = Bucket { state :: TVar BucketState @@ -52,41 +53,44 @@ data RateLimitState = RateLimitState { bucketKeys :: SC.Map RouteKey B.ByteString - , buckets :: SC.Map B.ByteString Bucket + , buckets :: SC.Map B.ByteString Bucket , globalLock :: Event } data DiscordResponseType - = Good - -- ^ A good response - LB.ByteString - (Maybe (BucketState, B.ByteString)) - -- ^ The ratelimit headers if we got them - | Ratelimited - -- ^ We hit a 429, no response and ratelimited - UTCTime - -- ^ Retry after - Bool - -- ^ Global ratelimit - (Maybe (BucketState, B.ByteString)) - | ServerError Int -- ^ Discord's error, we should retry (HTTP 5XX) - | ClientError Int LB.ByteString -- ^ Our error, we should fail - | InternalResponseError T.Text -- ^ Something went wrong with the http client + = -- | A good response + Good + LB.ByteString + (Maybe (BucketState, B.ByteString)) + -- ^ The ratelimit headers if we got them + | -- | We hit a 429, no response and ratelimited + Ratelimited + UTCTime + -- ^ Retry after + Bool + -- ^ Global ratelimit + (Maybe (BucketState, B.ByteString)) + | -- | Discord's error, we should retry (HTTP 5XX) + ServerError Int + | -- | Our error, we should fail + ClientError Int LB.ByteString + | -- | Something went wrong with the http client + InternalResponseError T.Text newtype GatewayResponse = GatewayResponse { url :: T.Text } - deriving stock ( Show ) + deriving stock (Show) instance Aeson.FromJSON GatewayResponse where parseJSON = Aeson.withObject "GatewayResponse" $ \v -> GatewayResponse <$> v .: "url" data BotGatewayResponse = BotGatewayResponse - { url :: T.Text + { url :: T.Text , shards :: Int } - deriving ( Show ) + deriving (Show) instance Aeson.FromJSON BotGatewayResponse where parseJSON = Aeson.withObject "BotGatewayResponse" $ \v -> diff --git a/Calamity/HTTP/Invite.hs b/Calamity/HTTP/Invite.hs --- a/Calamity/HTTP/Invite.hs +++ b/Calamity/HTTP/Invite.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + -- | Invite endpoints module Calamity.HTTP.Invite (InviteRequest (..)) where diff --git a/Calamity/HTTP/Reason.hs b/Calamity/HTTP/Reason.hs --- a/Calamity/HTTP/Reason.hs +++ b/Calamity/HTTP/Reason.hs @@ -21,5 +21,4 @@ route (Reason a _) = route a - action (Reason a r) = \u o -> - action a u (o <> header "X-Audit-Log-Reason" (encodeUtf8 r)) + action (Reason a r) u o = action a u (o <> header "X-Audit-Log-Reason" (encodeUtf8 r)) diff --git a/Calamity/HTTP/User.hs b/Calamity/HTTP/User.hs --- a/Calamity/HTTP/User.hs +++ b/Calamity/HTTP/User.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | User endpoints module Calamity.HTTP.User ( @@ -14,17 +15,17 @@ import Calamity.Types.Model.Guild import Calamity.Types.Model.User import Calamity.Types.Snowflake -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Default.Class import Data.Function ((&)) import Data.Text (Text) -import Optics.TH import Network.HTTP.Req +import Optics.TH data ModifyUserData = ModifyUserData { 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 + , avatar :: Maybe Text + -- ^ The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON ModifyUserData @@ -88,7 +89,8 @@ action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o action (GetCurrentUserGuilds GetCurrentUserGuildsOptions {before, after, limit}) = getWithP - ( "before" =:? (fromSnowflake <$> before) <> "after" =:? (fromSnowflake <$> after) + ( "before" =:? (fromSnowflake <$> before) + <> "after" =:? (fromSnowflake <$> after) <> "limit" =:? limit ) action (LeaveGuild _) = deleteWith diff --git a/Calamity/HTTP/Webhook.hs b/Calamity/HTTP/Webhook.hs --- a/Calamity/HTTP/Webhook.hs +++ b/Calamity/HTTP/Webhook.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Webhook endpoints module Calamity.HTTP.Webhook ( @@ -15,20 +16,19 @@ import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild import Calamity.Types.Snowflake -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Default.Class import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime import Optics -import PyF data CreateWebhookData = CreateWebhookData { 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 + , avatar :: Maybe Text + -- ^ The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data } deriving (Show) deriving (Aeson.ToJSON) via CalamityToJSON CreateWebhookData @@ -44,8 +44,8 @@ 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 + , avatar :: Maybe Text + -- ^ The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data , channelID :: Maybe (Snowflake Channel) } deriving (Show) diff --git a/Calamity/Interactions.hs b/Calamity/Interactions.hs --- a/Calamity/Interactions.hs +++ b/Calamity/Interactions.hs @@ -23,7 +23,7 @@ Displaying a 'View' @ - {-# LANGUAGE ApplicativeDo #-} + {\-# LANGUAGE ApplicativeDo #-\} let view = 'row' $ do a <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "defer" diff --git a/Calamity/Interactions/Eff.hs b/Calamity/Interactions/Eff.hs --- a/Calamity/Interactions/Eff.hs +++ b/Calamity/Interactions/Eff.hs @@ -14,10 +14,10 @@ import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake import Control.Applicative ((<|>)) -import Optics ((^.), (^?), _Just, (%)) import Data.Maybe (fromJust) +import Optics ((%), (^.), (^?), _Just) import Polysemy -import qualified Polysemy as P +import Polysemy qualified as P data InteractionEff m a where GetInteraction :: InteractionEff m Interaction @@ -39,4 +39,3 @@ 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 @@ -13,18 +13,18 @@ ) where import Calamity.HTTP -import Calamity.Interactions.Eff (InteractionEff, getInteractionID, getInteractionToken, getInteractionUser, getApplicationID) +import Calamity.Interactions.Eff (InteractionEff, getApplicationID, getInteractionID, getInteractionToken, getInteractionUser) import Calamity.Metrics.Eff (MetricEff) import Calamity.Types.LogEff (LogEff) import Calamity.Types.Model.Channel.Component (Component (ActionRow')) import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake (Snowflake) import Calamity.Types.Tellable -import Optics -import qualified Data.HashMap.Strict as H +import Data.HashMap.Strict qualified as H import Data.Text (Text) -import qualified Polysemy as P -import qualified Polysemy.State as P +import Optics +import Polysemy qualified as P +import Polysemy.State qualified as P import System.Random (getStdRandom, uniform) {- | Provide local state semantics to a running view, the state is keyed to the @@ -50,7 +50,8 @@ ) -- | Respond to an interaction with a globally visible message -respond :: forall t r. +respond :: + forall t r. (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => t -> P.Sem r (Either RestError ()) @@ -72,7 +73,8 @@ invoke $ CreateResponseMessage interactionID interactionToken opts -- | Respond to an interaction with an ephemeral message -respondEphemeral :: forall t r. +respondEphemeral :: + forall t r. (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => t -> P.Sem r (Either RestError ()) @@ -94,7 +96,8 @@ invoke $ CreateResponseMessage interactionID interactionToken opts -- | Respond to an interaction by editing the message that triggered the interaction -edit :: forall t r. +edit :: + forall t r. (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => t -> P.Sem r (Either RestError ()) @@ -116,7 +119,8 @@ invoke $ CreateResponseUpdate interactionID interactionToken opts -- | Create a follow up response to an interaction -followUp :: forall t r. +followUp :: + forall t r. (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => t -> P.Sem r (Either RestError ()) @@ -138,7 +142,8 @@ invoke $ CreateFollowupMessage applicationID interactionToken opts -- | Create an ephemeral follow up response to an interaction -followUpEphemeral :: forall t r. +followUpEphemeral :: + forall t r. (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => t -> P.Sem r (Either RestError ()) @@ -166,8 +171,9 @@ interactionToken <- getInteractionToken invoke $ CreateResponseDefer interactionID interactionToken False --- | Defer an interaction and show an ephemeral loading state, use @followUp@ --- later on +{- | Defer an interaction and show an ephemeral loading state, use @followUp@ + later on +-} deferEphemeral :: P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r => P.Sem r (Either RestError ()) deferEphemeral = do interactionID <- getInteractionID diff --git a/Calamity/Interactions/View.hs b/Calamity/Interactions/View.hs --- a/Calamity/Interactions/View.hs +++ b/Calamity/Interactions/View.hs @@ -28,24 +28,24 @@ import Calamity.Metrics.Eff (MetricEff) import Calamity.Types.LogEff (LogEff) import Calamity.Types.Model.Channel.Component (CustomID) -import qualified Calamity.Types.Model.Channel.Component as C +import Calamity.Types.Model.Channel.Component qualified as C import Calamity.Types.Model.Channel.Message (Message) import Calamity.Types.Model.Interaction import Calamity.Types.TokenEff (TokenEff) -import qualified Control.Concurrent.STM as STM -import Optics +import Control.Concurrent.STM qualified as STM import Control.Monad (guard, void) -import qualified Data.Aeson as Aeson -import qualified Data.List -import qualified Data.Set as S +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Optics +import Data.List qualified +import Data.Set qualified as S import Data.Text (Text) -import qualified GHC.TypeLits as E -import qualified Polysemy as P -import qualified Polysemy.Resource as P -import qualified Polysemy.State as P +import GHC.TypeLits qualified as E +import Optics +import Polysemy qualified as P +import Polysemy.Resource qualified as P +import Polysemy.State qualified as P import System.Random -import Data.Aeson ((.:?), (.:)) -import Data.Aeson.Optics data ViewComponent a = ViewComponent { component :: C.Component @@ -322,14 +322,15 @@ void . invoke $ DeleteMessage m m Left _ -> pure () --- | Run a 'View', returning the value passed to 'endView' --- --- This function will not return until 'endView' is used inside the view. --- If you want it to run in the background, consider using "Polysemy.Async". --- --- This is async exception safe, you can use libraries such as --- [polysemy-conc](https://hackage.haskell.org/package/polysemy-conc) to stop --- views after a timeout. +{- | Run a 'View', returning the value passed to 'endView' + + This function will not return until 'endView' is used inside the view. + If you want it to run in the background, consider using "Polysemy.Async". + + This is async exception safe, you can use libraries such as + [polysemy-conc](https://hackage.haskell.org/package/polysemy-conc) to stop + views after a timeout. +-} runView :: BotC r => -- | The initial view to render diff --git a/Calamity/Internal/BoundedStore.hs b/Calamity/Internal/BoundedStore.hs --- a/Calamity/Internal/BoundedStore.hs +++ b/Calamity/Internal/BoundedStore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | A thing for storing the last N things with IDs module Calamity.Internal.BoundedStore ( @@ -9,14 +10,14 @@ dropItem, ) where -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 Calamity.Internal.Utils (unlessM, whenM) +import Calamity.Types.Snowflake (HasID (getID), HasID', Snowflake) +import Control.Monad.State.Lazy (execState, when) +import Data.Default.Class (Default (..)) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as H +import Data.HashMap.Strict qualified as H import Deque.Lazy (Deque) -import qualified Deque.Lazy as DQ +import Deque.Lazy qualified as DQ import Optics import Optics.State.Operators ((%=), (.=)) diff --git a/Calamity/Internal/ConstructorName.hs b/Calamity/Internal/ConstructorName.hs --- a/Calamity/Internal/ConstructorName.hs +++ b/Calamity/Internal/ConstructorName.hs @@ -1,9 +1,10 @@ -- | Get the constructor name of something -module Calamity.Internal.ConstructorName - ( CtorName(..) - , GCtorName(..) ) where +module Calamity.Internal.ConstructorName ( + CtorName (..), + GCtorName (..), +) where -import GHC.Generics +import GHC.Generics class GCtorName f where gctorName :: f a -> String diff --git a/Calamity/Internal/IntColour.hs b/Calamity/Internal/IntColour.hs --- a/Calamity/Internal/IntColour.hs +++ b/Calamity/Internal/IntColour.hs @@ -1,3 +1,7 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket due to operator fixities" #-} + -- | An internal newtype for parsing colours module Calamity.Internal.IntColour ( IntColour (..), diff --git a/Calamity/Internal/LocalWriter.hs b/Calamity/Internal/LocalWriter.hs --- a/Calamity/Internal/LocalWriter.hs +++ b/Calamity/Internal/LocalWriter.hs @@ -1,14 +1,15 @@ {-# LANGUAGE TemplateHaskell #-} -- | A Writer monad that supports local writing, reverse reader I guess? -module Calamity.Internal.LocalWriter - ( LocalWriter(..) - , ltell - , llisten - , runLocalWriter ) where +module Calamity.Internal.LocalWriter ( + LocalWriter (..), + ltell, + llisten, + runLocalWriter, +) where -import qualified Polysemy as P -import qualified Polysemy.State as P +import Polysemy qualified as P +import Polysemy.State qualified as P data LocalWriter o m a where Ltell :: o -> LocalWriter o m () @@ -17,11 +18,14 @@ P.makeSem ''LocalWriter runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a) -runLocalWriter = P.runState mempty . P.reinterpretH - (\case - Ltell o -> do - P.modify' (<> o) >>= P.pureT - Llisten m -> do - mm <- P.runT m - (o, fa) <- P.raise $ runLocalWriter mm - pure $ fmap (o, ) fa) +runLocalWriter = + P.runState mempty + . P.reinterpretH + ( \case + Ltell o -> do + P.modify' (<> o) >>= P.pureT + Llisten m -> do + mm <- P.runT m + (o, fa) <- P.raise $ runLocalWriter mm + pure $ fmap (o,) fa + ) diff --git a/Calamity/Internal/RunIntoIO.hs b/Calamity/Internal/RunIntoIO.hs --- a/Calamity/Internal/RunIntoIO.hs +++ b/Calamity/Internal/RunIntoIO.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE TemplateHaskell #-} - -- | Something for converting polysemy actions into IO actions -module Calamity.Internal.RunIntoIO - ( runSemToIO - , bindSemToIO ) where +module Calamity.Internal.RunIntoIO ( + runSemToIO, + bindSemToIO, +) where -import Data.Functor +import Data.Functor -import qualified Polysemy as P -import qualified Polysemy.Final as P +import Polysemy qualified as P +import Polysemy.Final qualified as P runSemToIO :: forall r a. P.Member (P.Final IO) r => P.Sem r a -> P.Sem r (IO (Maybe a)) runSemToIO m = P.withStrategicToFinal $ do diff --git a/Calamity/Internal/SnowflakeMap.hs b/Calamity/Internal/SnowflakeMap.hs --- a/Calamity/Internal/SnowflakeMap.hs +++ b/Calamity/Internal/SnowflakeMap.hs @@ -5,9 +5,9 @@ import Calamity.Types.Snowflake import Data.Aeson (FromJSON (..), ToJSON (..), withArray) import Data.Data -import qualified Data.Foldable as F +import Data.Foldable qualified as F import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as SH +import Data.HashMap.Strict qualified as SH import Data.Hashable import GHC.Exts (IsList) import Optics diff --git a/Calamity/Internal/UnixTimestamp.hs b/Calamity/Internal/UnixTimestamp.hs --- a/Calamity/Internal/UnixTimestamp.hs +++ b/Calamity/Internal/UnixTimestamp.hs @@ -1,8 +1,8 @@ -- | Internal newtype for deserializing timestamps module Calamity.Internal.UnixTimestamp ( - UnixTimestamp (..), - unixToMilliseconds, - millisecondsToUnix, + UnixTimestamp (..), + unixToMilliseconds, + millisecondsToUnix, ) where import Calamity.Internal.Utils () @@ -15,46 +15,46 @@ import TextShow newtype UnixTimestamp = UnixTimestamp - { unUnixTimestamp :: UTCTime - } - deriving (Show) via UTCTime - deriving (TextShow) via FromStringShow UTCTime + { unUnixTimestamp :: UTCTime + } + deriving (Show) via UTCTime + deriving (TextShow) via FromStringShow UTCTime unixToMilliseconds :: UnixTimestamp -> Word64 unixToMilliseconds = - unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> (* 1000) - >>> round + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> (* 1000) + >>> round millisecondsToUnix :: Word64 -> UnixTimestamp millisecondsToUnix = - toRational - >>> fromRational - >>> (/ 1000) - >>> posixSecondsToUTCTime - >>> UnixTimestamp + toRational + >>> fromRational + >>> (/ 1000) + >>> posixSecondsToUTCTime + >>> UnixTimestamp instance ToJSON UnixTimestamp where - toJSON = - unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> round - >>> toJSON @Word64 - toEncoding = - unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> round - >>> word64 + toJSON = + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> round + >>> toJSON @Word64 + toEncoding = + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> round + >>> word64 instance FromJSON UnixTimestamp where - parseJSON = - withScientific "UnixTimestamp" $ - toRational - >>> fromRational - >>> posixSecondsToUTCTime - >>> UnixTimestamp - >>> pure + parseJSON = + withScientific "UnixTimestamp" $ + toRational + >>> fromRational + >>> posixSecondsToUTCTime + >>> UnixTimestamp + >>> pure diff --git a/Calamity/Internal/Utils.hs b/Calamity/Internal/Utils.hs --- a/Calamity/Internal/Utils.hs +++ b/Calamity/Internal/Utils.hs @@ -29,16 +29,16 @@ import Calamity.Internal.RunIntoIO import Calamity.Types.LogEff import Control.Applicative -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Aeson.Encoding (null_) import Data.Default.Class -import qualified Data.Map as M +import Data.Map qualified as M import Data.Maybe (catMaybes) import Data.Semigroup (Last (..)) import Data.Text -import qualified Data.Vector.Unboxing as VU -import qualified DiPolysemy as Di -import qualified Polysemy as P +import Data.Vector.Unboxing qualified as VU +import DiPolysemy qualified as Di +import Polysemy qualified as P import TextShow {- | Like whileM, but stateful effects are not preserved to mitigate memory leaks diff --git a/Calamity/Metrics/Eff.hs b/Calamity/Metrics/Eff.hs --- a/Calamity/Metrics/Eff.hs +++ b/Calamity/Metrics/Eff.hs @@ -17,7 +17,7 @@ import Calamity.Metrics.Internal import Data.Default.Class -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Text import Optics.TH import Polysemy diff --git a/Calamity/Metrics/Internal.hs b/Calamity/Metrics/Internal.hs --- a/Calamity/Metrics/Internal.hs +++ b/Calamity/Metrics/Internal.hs @@ -1,8 +1,9 @@ -- | Internal data structures to the metrics effect -module Calamity.Metrics.Internal - ( Counter(..) - , Gauge(..) - , Histogram(..) ) where +module Calamity.Metrics.Internal ( + Counter (..), + Gauge (..), + Histogram (..), +) where -- | A handle to a counter newtype Counter = Counter diff --git a/Calamity/Metrics/Noop.hs b/Calamity/Metrics/Noop.hs --- a/Calamity/Metrics/Noop.hs +++ b/Calamity/Metrics/Noop.hs @@ -1,20 +1,18 @@ -- | Noop handler for metrics -module Calamity.Metrics.Noop - ( runMetricsNoop ) where +module Calamity.Metrics.Noop (runMetricsNoop) where -import Calamity.Metrics.Eff -import Calamity.Metrics.Internal +import Calamity.Metrics.Eff +import Calamity.Metrics.Internal -import Data.Default.Class +import Data.Default.Class -import Polysemy +import Polysemy runMetricsNoop :: Sem (MetricEff ': r) a -> Sem r a runMetricsNoop = interpret $ \case - RegisterCounter _ _ -> pure (Counter 0) - RegisterGauge _ _ -> pure (Gauge 0) - RegisterHistogram _ _ _ -> pure (Histogram 0) - - AddCounter _ _ -> pure def - ModifyGauge _ _ -> pure def - ObserveHistogram _ _ -> pure def + RegisterCounter _ _ -> pure (Counter 0) + RegisterGauge _ _ -> pure (Gauge 0) + RegisterHistogram {} -> pure (Histogram 0) + AddCounter _ _ -> pure def + ModifyGauge _ _ -> pure def + ObserveHistogram _ _ -> pure def diff --git a/Calamity/Types/CDNAsset.hs b/Calamity/Types/CDNAsset.hs --- a/Calamity/Types/CDNAsset.hs +++ b/Calamity/Types/CDNAsset.hs @@ -1,15 +1,15 @@ -- | Things that can be fetched from the discord CDN -module Calamity.Types.CDNAsset - ( CDNAsset (..), - fetchAsset, - fetchAsset', - ) +module Calamity.Types.CDNAsset ( + CDNAsset (..), + fetchAsset, + fetchAsset', +) where -import qualified Control.Exception.Safe as Ex +import Control.Exception.Safe qualified as Ex import Data.ByteString.Lazy (ByteString) -import qualified Network.HTTP.Req as Req -import qualified Polysemy as P +import Network.HTTP.Req qualified as Req +import Polysemy qualified as P -- | Retrieve the asset from the CDN, like 'fetchAsset' but gives you more control fetchAsset' :: (CDNAsset a, Req.MonadHttp m) => a -> m ByteString diff --git a/Calamity/Types/LogEff.hs b/Calamity/Types/LogEff.hs --- a/Calamity/Types/LogEff.hs +++ b/Calamity/Types/LogEff.hs @@ -6,11 +6,11 @@ LogC, ) where -import qualified Df1 +import Df1 qualified import DiPolysemy -import qualified Polysemy as P +import Polysemy qualified as P type LogEff = Di Df1.Level Df1.Path Df1.Message diff --git a/Calamity/Types/Model/Avatar.hs b/Calamity/Types/Model/Avatar.hs --- a/Calamity/Types/Model/Avatar.hs +++ b/Calamity/Types/Model/Avatar.hs @@ -10,7 +10,7 @@ import {-# SOURCE #-} Calamity.Types.Model.User import Calamity.Types.Snowflake (Snowflake, fromSnowflake) import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) -import qualified Data.Text as T +import Data.Text qualified as T import Network.HTTP.Req ((/:), (/~)) import Optics (makeFieldLabelsNoPrefix) import TextShow (showt) 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 @@ -30,7 +30,7 @@ import Calamity.Types.Model.Guild.Permissions (Permissions) import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH 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 @@ -7,7 +7,7 @@ import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Word import Optics.TH 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 @@ -3,7 +3,7 @@ -- | Types of channels module Calamity.Types.Model.Channel.ChannelType (ChannelType (..)) where -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Scientific import Optics.TH import TextShow.TH 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 @@ -26,14 +26,14 @@ import Calamity.Types.Model.Guild.Emoji import Control.Monad (replicateM) import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson +import Data.Maybe (catMaybes) import Data.Scientific (toBoundedInteger) -import qualified Data.Text as T +import Data.Text qualified as T import Optics.TH import System.Random (Uniform) import System.Random.Stateful (Uniform (uniformM), UniformRange (uniformRM)) import TextShow.TH -import Data.Maybe (catMaybes) newtype CustomID = CustomID T.Text deriving stock (Eq, Ord, Show) @@ -131,7 +131,6 @@ $(deriveTextShow ''Button) $(makeFieldLabelsNoPrefix ''Button) - instance Aeson.FromJSON Button where parseJSON = Aeson.withObject "Components.Button" $ \v -> Button @@ -153,13 +152,13 @@ instance CalamityToJSON' LinkButton where toPairs LinkButton {..} = - [ "style" .= style - , "label" .?= label - , "emoji" .?= emoji - , "url" .= url - , "disabled" .= disabled - , "type" .= ButtonType - ] + [ "style" .= style + , "label" .?= label + , "emoji" .?= emoji + , "url" .= url + , "disabled" .= disabled + , "type" .= ButtonType + ] instance Aeson.FromJSON LinkButton where parseJSON = Aeson.withObject "Components.Linkbutton" $ \v -> @@ -219,12 +218,12 @@ instance CalamityToJSON' SelectOption where toPairs SelectOption {..} = - [ "label" .= label - , "value" .= value - , "description" .?= description - , "emoji" .?= emoji - , "default" .= default_ - ] + [ "label" .= label + , "value" .= value + , "description" .?= description + , "emoji" .?= emoji + , "default" .= default_ + ] instance Aeson.FromJSON SelectOption where parseJSON = Aeson.withObject "Components.SelectOption" $ \v -> @@ -251,14 +250,14 @@ instance CalamityToJSON' Select where toPairs Select {..} = - [ "options" .= options - , "placeholder" .?= placeholder - , "min_values" .?= minValues - , "max_values" .?= maxValues - , "disabled" .= disabled - , "custom_id" .= customID - , "type" .= SelectType - ] + [ "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 -> @@ -322,16 +321,16 @@ 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 - ] + [ "style" .= style + , "label" .= label + , "min_length" .= minLength + , "max_length" .= maxLength + , "required" .= required + , "value" .= value + , "placeholder" .= placeholder + , "custom_id" .= customID + , "type" .= TextInputType + ] instance Aeson.FromJSON TextInput where parseJSON = Aeson.withObject "Components.TextInput" $ \v -> 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 @@ -8,10 +8,10 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Time import Optics.TH -import qualified TextShow +import TextShow qualified data DMChannel = DMChannel { id :: Snowflake 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 @@ -21,7 +21,7 @@ import Calamity.Internal.IntColour (IntColour (..)) import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Colour (Colour) import Data.Default.Class import Data.Semigroup @@ -30,7 +30,7 @@ import Data.Word import Optics ((%~), (&), (^.)) import Optics.TH -import qualified TextShow +import TextShow qualified import TextShow.TH data Embed = Embed 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 @@ -8,11 +8,11 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Time import Optics.TH -import qualified TextShow +import TextShow qualified data GroupChannel = GroupChannel { id :: Snowflake GroupChannel 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 @@ -16,7 +16,7 @@ import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild import Calamity.Types.Snowflake import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Optics ((^.)) import Optics.TH import TextShow.TH 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 @@ -8,7 +8,7 @@ import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH 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 @@ -10,11 +10,11 @@ import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Time import Optics.TH -import qualified TextShow +import TextShow qualified data TextChannel = TextChannel { id :: Snowflake 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 @@ -10,7 +10,7 @@ import Calamity.Types.Model.Guild.Overwrite import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH 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 @@ -24,15 +24,15 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified 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.Vector.Unboxing qualified as UV import Data.Word (Word64) import Optics.TH -import qualified TextShow +import TextShow qualified import TextShow.TH data MessageAuthorWebhook = MessageAuthorWebhook @@ -114,7 +114,9 @@ ( \v -> Webhook' <$> ( MessageAuthorWebhook - <$> v .: "id" <*> v .: "username" <*> v .:? "avatar" + <$> v .: "id" + <*> v .: "username" + <*> v .:? "avatar" ) ) =<< v .: "author" 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 @@ -6,7 +6,7 @@ import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (toPairs), (.=)) import Calamity.Types.Model.Guild.Emoji import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Optics.TH import TextShow.TH 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 @@ -11,13 +11,13 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:!), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Time -import qualified Data.Vector.Unboxing as UV +import Data.Vector.Unboxing qualified as UV import Data.Word import Optics.TH -import qualified TextShow +import TextShow qualified data UpdatedMessage = UpdatedMessage { id :: Snowflake Message 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 @@ -8,7 +8,7 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH 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 @@ -14,11 +14,11 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Scientific import Data.Text (Text) import Optics.TH -import qualified TextShow +import TextShow qualified import TextShow.TH data AuditLog = AuditLog 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 @@ -7,7 +7,7 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Optics.TH import TextShow.TH 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 @@ -15,18 +15,18 @@ (.=), ) import Calamity.Types.CDNAsset (CDNAsset (..)) -import Calamity.Types.Model.Guild.Role +import {-# SOURCE #-} Calamity.Types.Model.Guild.Role import Calamity.Types.Model.User import Calamity.Types.Snowflake import Calamity.Utils.CDNUrl (cdnURL) import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson -import qualified Data.Text as T +import Data.Aeson qualified as Aeson +import Data.Text qualified as T import Data.Vector.Unboxing (Vector) import Network.HTTP.Req ((/:)) import Optics.TH import TextShow (showt) -import qualified TextShow +import TextShow qualified data Emoji = Emoji { id :: Snowflake Emoji diff --git a/Calamity/Types/Model/Guild/Emoji.hs-boot b/Calamity/Types/Model/Guild/Emoji.hs-boot deleted file mode 100644 --- a/Calamity/Types/Model/Guild/Emoji.hs-boot +++ /dev/null @@ -1,13 +0,0 @@ --- | Discord Emojis -module Calamity.Types.Model.Guild.Emoji - ( RawEmoji - ) where - -import Data.Aeson - -data RawEmoji - -instance Show RawEmoji -instance Eq RawEmoji - -instance FromJSON 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 @@ -12,7 +12,7 @@ ) where import Calamity.Internal.SnowflakeMap (SnowflakeMap) -import qualified Calamity.Internal.SnowflakeMap as SM +import Calamity.Internal.SnowflakeMap qualified as SM import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) import Calamity.Types.CDNAsset (CDNAsset (..)) import Calamity.Types.Model.Channel @@ -25,17 +25,17 @@ import Calamity.Types.Snowflake import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as LH +import Data.HashMap.Strict qualified as LH import Data.Maybe -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time import Data.Word import Network.HTTP.Req ((/:), (/~)) import Optics -import qualified TextShow +import TextShow qualified import TextShow.TH (deriveTextShow) data GuildIcon = GuildIcon @@ -132,7 +132,8 @@ presences' <- do presences' <- v .: "presences" - pure . LH.fromList + pure + . LH.fromList . mapMaybe ( Aeson.parseMaybe @Aeson.Object @(Snowflake User, Presence) ( \m -> do 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 @@ -7,11 +7,11 @@ import Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.User import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Time (UTCTime) import Optics.TH -import qualified TextShow +import TextShow qualified data Invite = Invite { code :: Text 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 @@ -10,16 +10,16 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Colour (Colour) import Data.Text (Text) import Data.Text.Read (decimal) import Data.Time import Data.Vector.Unboxing (Vector) -import qualified Data.Vector.Unboxing as V +import Data.Vector.Unboxing qualified as V import Data.Word (Word64) import Optics.TH -import qualified TextShow +import TextShow qualified data Member = Member { id :: Snowflake User 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 @@ -7,7 +7,7 @@ import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Optics.TH import TextShow.TH 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 @@ -9,18 +9,18 @@ import Calamity.Internal.IntColour import Calamity.Internal.Utils import Calamity.Types.CDNAsset (CDNAsset (..)) -import {-# SOURCE #-} Calamity.Types.Model.Guild.Emoji +import Calamity.Types.Model.Guild.Emoji import Calamity.Types.Model.Guild.Permissions import Calamity.Types.Snowflake import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Colour import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Network.HTTP.Req ((/:), (/~)) import Optics.TH -import qualified TextShow +import TextShow qualified data RoleIcon = RoleIcon { roleID :: Snowflake Role @@ -64,6 +64,7 @@ parseJSON = Aeson.withObject "Role" $ \v -> do id <- v .: "id" icon <- (RoleIcon id <$>) <$> v .: "icon" + emoji <- (UnicodeEmoji <$>) <$> v .:? "unicode_emoji" Role <$> pure id @@ -71,7 +72,7 @@ <*> (fromIntColour <$> v .: "color") <*> v .: "hoist" <*> pure icon - <*> v .:? "unicode_emoji" + <*> pure emoji <*> v .: "position" <*> v .: "permissions" <*> v .: "managed" diff --git a/Calamity/Types/Model/Guild/Role.hs-boot b/Calamity/Types/Model/Guild/Role.hs-boot new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Role.hs-boot @@ -0,0 +1,16 @@ +-- | Guild roles +module Calamity.Types.Model.Guild.Role ( + Role, + RoleIcon, +) where + +import Data.Aeson + +data RoleIcon + +data Role + +instance Show Role +instance Eq Role + +instance FromJSON 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 @@ -7,7 +7,7 @@ import Calamity.Types.Model.Guild.Guild import Calamity.Types.Snowflake import Data.Aeson ((.!=), (.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Optics.TH import TextShow.TH 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 @@ -18,13 +18,13 @@ import Calamity.Types.Model.Guild.Member (Member) import Calamity.Types.Model.User (User) import Calamity.Types.Snowflake -import Data.Aeson ((.:), (.:?), (.!=)) -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as H +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.HashMap.Strict qualified as H import Data.Scientific (toBoundedInteger) -import qualified Data.Text as T +import Data.Text qualified as T import Optics.TH -import qualified TextShow +import TextShow qualified import TextShow.TH -- | Empty type to flag application IDs 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 @@ -15,13 +15,13 @@ import Calamity.Internal.Utils import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Scientific import Data.Text (Text) import Data.Time (UTCTime) import Data.Word import Optics.TH -import qualified TextShow +import TextShow qualified import TextShow.TH data ActivityType 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 @@ -12,7 +12,7 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH 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 @@ -16,15 +16,15 @@ import Calamity.Types.Snowflake import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Colour (Colour) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Read (decimal) import Data.Word import Network.HTTP.Req ((/:), (/~)) import Optics.TH -import qualified TextShow +import TextShow qualified import TextShow.TH data UserBanner = UserBanner @@ -85,7 +85,7 @@ newtype instance Partial User = PartialUser { id :: Snowflake User } - deriving (Show, Eq) + deriving stock (Show, Eq) deriving (HasID User) via HasIDField "id" (Partial User) instance Aeson.FromJSON (Partial User) where 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 @@ -3,13 +3,13 @@ -- | Voice regions module Calamity.Types.Model.Voice.VoiceRegion (VoiceRegion (..)) where +import Calamity.Internal.Utils import Calamity.Types.Snowflake import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH -import Calamity.Internal.Utils data VoiceRegion = VoiceRegion { id :: Snowflake VoiceRegion @@ -24,13 +24,13 @@ instance CalamityToJSON' VoiceRegion where toPairs VoiceRegion {..} = - [ "id" .= id - , "name" .= name - , "vip" .= vip - , "optimal" .= optimal - , "deprecated" .= deprecated - , "custom" .= custom - ] + [ "id" .= id + , "name" .= name + , "vip" .= vip + , "optimal" .= optimal + , "deprecated" .= deprecated + , "custom" .= custom + ] instance Aeson.FromJSON VoiceRegion where parseJSON = Aeson.withObject "VoiceRegion" $ \v -> 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 @@ -8,7 +8,7 @@ import Calamity.Types.Model.User import Calamity.Types.Snowflake import Data.Aeson ((.:), (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import Data.Text (Text) import Optics.TH import TextShow.TH diff --git a/Calamity/Types/Snowflake.hs b/Calamity/Types/Snowflake.hs --- a/Calamity/Types/Snowflake.hs +++ b/Calamity/Types/Snowflake.hs @@ -15,7 +15,7 @@ import Data.Hashable import Data.Kind import Data.Text.Read -import qualified Data.Vector.Unboxing as U +import Data.Vector.Unboxing qualified as U import Data.Word import GHC.Records (HasField (getField)) import TextShow @@ -26,7 +26,7 @@ newtype Snowflake (t :: Type) = Snowflake { fromSnowflake :: Word64 } - deriving (Eq, Ord, Data) + deriving stock (Eq, Ord, Data) deriving newtype (Show, TextShow, FromJSONKey) deriving newtype (ToJSONKey, U.Unboxable) deriving newtype (ToHttpApiData) diff --git a/Calamity/Types/Tellable.hs b/Calamity/Types/Tellable.hs --- a/Calamity/Types/Tellable.hs +++ b/Calamity/Types/Tellable.hs @@ -25,11 +25,11 @@ import Calamity.Types.Snowflake import Data.Default.Class import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Lazy as L +import Data.Text qualified as T +import Data.Text.Lazy qualified as L import Optics -import qualified Polysemy as P -import qualified Polysemy.Error as P +import Polysemy qualified as P +import Polysemy.Error qualified as P -- | A wrapper type for allowing mentions newtype TMention a = TMention (Snowflake a) diff --git a/Calamity/Types/Upgradeable.hs b/Calamity/Types/Upgradeable.hs --- a/Calamity/Types/Upgradeable.hs +++ b/Calamity/Types/Upgradeable.hs @@ -1,24 +1,24 @@ -- | Things that can be upgraded from snowflakes to their full data -module Calamity.Types.Upgradeable - ( Upgradeable(..) ) where +module Calamity.Types.Upgradeable (Upgradeable (..)) where -import Calamity.Cache.Eff -import Calamity.Client.Types -import Calamity.HTTP as H -import Calamity.Internal.Utils -import qualified Calamity.Internal.SnowflakeMap as SM -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake -import Control.Applicative -import Optics -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified Polysemy.NonDet as P +import Calamity.Cache.Eff +import Calamity.Client.Types +import Calamity.HTTP as H +import Calamity.Internal.SnowflakeMap qualified as SM +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Control.Applicative +import Optics +import Polysemy qualified as P +import Polysemy.Fail qualified as P +import Polysemy.NonDet qualified as P --- | A typeclass that represents snowflakes that can be upgraded to their --- complete data, either through the cache or HTTP. +{- | A typeclass that represents snowflakes that can be upgraded to their + complete data, either through the cache or HTTP. +-} class Upgradeable a ids | a -> ids, ids -> a where -- | Upgrade a snowflake to its complete data. -- @@ -85,30 +85,34 @@ pure c' instance Upgradeable VoiceChannel (Snowflake VoiceChannel) where - upgrade s = upgrade (coerceSnowflake @_ @Channel s) <&> \case - Just (GuildChannel' (GuildVoiceChannel vc)) -> Just vc - _ -> Nothing + upgrade s = + upgrade (coerceSnowflake @_ @Channel s) <&> \case + Just (GuildChannel' (GuildVoiceChannel vc)) -> Just vc + _ -> Nothing instance Upgradeable DMChannel (Snowflake DMChannel) where - upgrade s = upgrade (coerceSnowflake @_ @Channel s) <&> \case - Just (DMChannel' dc) -> Just dc - _ -> Nothing + upgrade s = + upgrade (coerceSnowflake @_ @Channel s) <&> \case + Just (DMChannel' dc) -> Just dc + _ -> Nothing instance Upgradeable GroupChannel (Snowflake GroupChannel) where - upgrade s = upgrade (coerceSnowflake @_ @Channel s) <&> \case - Just (GroupChannel' gc) -> Just gc - _ -> Nothing + upgrade s = + upgrade (coerceSnowflake @_ @Channel s) <&> \case + Just (GroupChannel' gc) -> Just gc + _ -> Nothing instance Upgradeable TextChannel (Snowflake TextChannel) where - upgrade s = upgrade (coerceSnowflake @_ @Channel s) <&> \case - Just (GuildChannel' (GuildTextChannel tc)) -> Just tc - _ -> Nothing + upgrade s = + upgrade (coerceSnowflake @_ @Channel s) <&> \case + Just (GuildChannel' (GuildTextChannel tc)) -> Just tc + _ -> Nothing instance Upgradeable Category (Snowflake Category) where - upgrade s = upgrade (coerceSnowflake @_ @Channel s) <&> \case - Just (GuildChannel' (GuildCategory c)) -> Just c - _ -> Nothing - + upgrade s = + upgrade (coerceSnowflake @_ @Channel s) <&> \case + Just (GuildChannel' (GuildCategory c)) -> Just c + _ -> Nothing instance Upgradeable Emoji (Snowflake Guild, Snowflake Emoji) where upgrade (gid, eid) = P.runNonDetMaybe (getcache <|> gethttp) diff --git a/Calamity/Utils.hs b/Calamity/Utils.hs --- a/Calamity/Utils.hs +++ b/Calamity/Utils.hs @@ -1,9 +1,10 @@ -- | Useful things -module Calamity.Utils - ( module Calamity.Utils.Permissions - , module Calamity.Utils.Message - , module Calamity.Utils.Colour ) where +module Calamity.Utils ( + module Calamity.Utils.Permissions, + module Calamity.Utils.Message, + module Calamity.Utils.Colour, +) where -import Calamity.Utils.Colour -import Calamity.Utils.Message -import Calamity.Utils.Permissions +import Calamity.Utils.Colour +import Calamity.Utils.Message +import Calamity.Utils.Permissions diff --git a/Calamity/Utils/CDNUrl.hs b/Calamity/Utils/CDNUrl.hs --- a/Calamity/Utils/CDNUrl.hs +++ b/Calamity/Utils/CDNUrl.hs @@ -5,8 +5,8 @@ isGIFAsset, ) where -import qualified Data.Text as T -import qualified Network.HTTP.Req as Req +import Data.Text qualified as T +import Network.HTTP.Req qualified as Req -- | The CDN URL cdnURL :: Req.Url 'Req.Https @@ -16,7 +16,8 @@ isGIFAsset :: T.Text -> Bool isGIFAsset = T.isPrefixOf "a_" --- | Generate \'hash.ext\' for an asset hash. @ext@ will be \'gif\' for animated --- assets, \'png\' otherwise. +{- | Generate \'hash.ext\' for an asset hash. @ext@ will be \'gif\' for animated + assets, \'png\' otherwise. +-} assetHashFile :: T.Text -> T.Text assetHashFile h = if isGIFAsset h then h <> ".gif" else h <> ".png" diff --git a/Calamity/Utils/Colour.hs b/Calamity/Utils/Colour.hs --- a/Calamity/Utils/Colour.hs +++ b/Calamity/Utils/Colour.hs @@ -1,15 +1,17 @@ -- | Discord colour utilities -module Calamity.Utils.Colour - ( colourToWord64 - , colourFromWord64 - -- * Useful colours - , blurple - , greyple ) where +module Calamity.Utils.Colour ( + colourToWord64, + colourFromWord64, -import Calamity.Internal.IntColour + -- * Useful colours + blurple, + greyple, +) where -import Data.Colour -import Data.Colour.SRGB ( sRGB24 ) +import Calamity.Internal.IntColour + +import Data.Colour +import Data.Colour.SRGB (sRGB24) blurple :: (Ord a, Floating a) => Colour a blurple = sRGB24 0x72 0x89 0xda diff --git a/Calamity/Utils/Message.hs b/Calamity/Utils/Message.hs --- a/Calamity/Utils/Message.hs +++ b/Calamity/Utils/Message.hs @@ -39,7 +39,7 @@ import Data.Foldable (Foldable (foldl')) import Data.Maybe (fromMaybe) import Data.String (IsString, fromString) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Records (HasField (getField)) import Optics import TextShow (TextShow (showt)) @@ -101,7 +101,9 @@ T.Text -> T.Text codeblock' lang content = - "```" <> fromMaybe "" lang <> "\n" + "```" + <> fromMaybe "" lang + <> "\n" <> escapeCodeblocks content <> "\n```" @@ -227,9 +229,8 @@ -- | If discord should error when replying to deleted messages Bool -> MessageReference -asReference msg failIfNotExists = +asReference msg = MessageReference (Just $ getID @Message msg) (Just $ getID @Channel msg) (msg ^. #guildID) - failIfNotExists diff --git a/Calamity/Utils/Permissions.hs b/Calamity/Utils/Permissions.hs --- a/Calamity/Utils/Permissions.hs +++ b/Calamity/Utils/Permissions.hs @@ -1,39 +1,41 @@ -- | Permission utilities -module Calamity.Utils.Permissions - ( basePermissions - , applyOverwrites - , PermissionsIn(..) - , PermissionsIn'(..) ) where +module Calamity.Utils.Permissions ( + basePermissions, + applyOverwrites, + PermissionsIn (..), + PermissionsIn' (..), +) where -import Calamity.Client.Types -import Calamity.Types.Model.Channel.Guild -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Member -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Model.Guild.Permissions -import Calamity.Types.Model.User -import Calamity.Types.Snowflake -import Calamity.Types.Upgradeable -import Data.Maybe (mapMaybe) -import Data.Flags -import qualified Data.Vector.Unboxing as V +import Calamity.Client.Types +import Calamity.Internal.SnowflakeMap qualified as SM +import Calamity.Types.Model.Channel.Guild +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Calamity.Types.Upgradeable +import Data.Flags +import Data.Foldable (Foldable (foldl')) +import Data.Maybe (mapMaybe) +import Data.Vector.Unboxing qualified as V import Optics -import qualified Polysemy as P -import Data.Foldable (Foldable(foldl')) -import qualified Calamity.Internal.SnowflakeMap as SM +import Polysemy qualified as P -- | 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) - permsEveryone = maybe noFlags (^. #permissions) everyoneRole - roleIDs = V.toList $ m ^. #roles - rolePerms = mapMaybe (\rid -> g ^? #roles % ix rid % #permissions) roleIDs - perms = foldl' andFlags noFlags (permsEveryone:rolePerms) - in if perms .<=. administrator - then allFlags - else perms + | otherwise = + let everyoneRole = g ^. #roles % at (coerceSnowflake $ getID @Guild g) + permsEveryone = maybe noFlags (^. #permissions) everyoneRole + roleIDs = V.toList $ m ^. #roles + 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 @@ -46,20 +48,20 @@ applyOverwrites c m p | p .<=. administrator = allFlags | otherwise = - 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 = 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 = overwrites c ^. at (coerceSnowflake @_ @Overwrite $ getID @Member m) - memberAllow = maybe noFlags (^. #allow) memberOverwrite - memberDeny = maybe noFlags (^. #deny) memberOverwrite - p''' = p'' .-. memberDeny .+. memberAllow - in p''' + 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 = 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 = overwrites c ^. at (coerceSnowflake @_ @Overwrite $ getID @Member m) + memberAllow = maybe noFlags (^. #allow) memberOverwrite + memberDeny = maybe noFlags (^. #deny) memberOverwrite + p''' = p'' .-. memberDeny .+. memberAllow + in p''' -- | Things that 'Member's have 'Permissions' in class PermissionsIn a where @@ -77,23 +79,24 @@ -- | A 'Member'\'s 'Permissions' in a guild are just their roles instance PermissionsIn Guild where - permissionsIn g m = basePermissions g m + permissionsIn = basePermissions -- | A variant of 'PermissionsIn' that will use the cache/http. class PermissionsIn' a where -- | Calculate the permissions of something that has a 'User' id permissionsIn' :: (BotC r, HasID User u) => a -> u -> P.Sem r Permissions --- | A 'User''s 'Permissions' in a channel are their roles and overwrites --- --- This will fetch the guild from the cache or http as needed +{- | A 'User''s 'Permissions' in a channel are their roles and overwrites + + This will fetch the guild from the cache or http as needed +-} instance PermissionsIn' GuildChannel where permissionsIn' c (getID @User -> uid) = do m <- upgrade (getID @Guild c, coerceSnowflake @_ @Member uid) g <- upgrade (getID @Guild c) case (m, g) of (Just m, Just g') -> pure $ permissionsIn (g', c) m - _cantFind -> pure noFlags + _cantFind -> pure noFlags -- | A 'Member'\'s 'Permissions' in a guild are just their roles instance PermissionsIn' Guild where @@ -103,19 +106,21 @@ Just m' -> pure $ permissionsIn g m' Nothing -> pure noFlags --- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites --- --- This will fetch the guild and channel from the cache or http as needed +{- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites + + This will fetch the guild and channel from the cache or http as needed +-} instance PermissionsIn' (Snowflake GuildChannel) where permissionsIn' cid u = do c <- upgrade cid case c of - Just c' -> permissionsIn' c' u - Nothing -> pure noFlags + Just c' -> permissionsIn' c' u + Nothing -> pure noFlags --- | A 'Member'\'s 'Permissions' in a guild are just their roles --- --- This will fetch the guild from the cache or http as needed +{- | A 'Member'\'s 'Permissions' in a guild are just their roles + + This will fetch the guild from the cache or http as needed +-} instance PermissionsIn' (Snowflake Guild) where permissionsIn' gid u = do g <- upgrade gid diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -1,239 +1,240 @@ -cabal-version: 2.0 - --- This file has been generated from package.yaml by hpack version 0.34.4. --- --- see: https://github.com/sol/hpack +cabal-version: 2.0 +name: calamity +version: 0.8.0.0 +synopsis: A library for writing discord bots in haskell +description: + Please see the README on GitHub at -name: calamity -version: 0.7.1.0 -synopsis: A library for writing discord bots in haskell -description: Please see the README on GitHub at -category: Network, Web -homepage: https://github.com/simmsb/calamity -bug-reports: https://github.com/simmsb/calamity/issues -author: Ben Simms -maintainer: ben@bensimms.moe -copyright: 2020 Ben Simms -license: MIT -license-file: LICENSE -build-type: Simple -tested-with: - GHC == 8.10.7, GHC == 9.2.5 +category: Network, Web +homepage: https://github.com/simmsb/calamity +bug-reports: https://github.com/simmsb/calamity/issues +author: Ben Simms +maintainer: ben@bensimms.moe +copyright: 2020 Ben Simms +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: GHC ==9.4.4 extra-source-files: - README.md - ChangeLog.md -extra-doc-files: - README.md + ChangeLog.md + README.md +extra-doc-files: README.md + source-repository head - type: git + type: git location: https://github.com/simmsb/calamity library exposed-modules: - Calamity - Calamity.Cache.Eff - Calamity.Cache.InMemory - Calamity.Client - Calamity.Client.Client - Calamity.Client.ShardManager - Calamity.Client.Types - Calamity.Commands - Calamity.Commands.CalamityParsers - Calamity.Commands.Context - Calamity.Commands.Dsl - Calamity.Commands.Help - Calamity.Commands.Types - Calamity.Commands.Utils - Calamity.Gateway - Calamity.Gateway.DispatchEvents - Calamity.Gateway.Intents - Calamity.Gateway.Shard - Calamity.Gateway.Types - Calamity.HTTP - Calamity.HTTP.AuditLog - Calamity.HTTP.Channel - Calamity.HTTP.Emoji - Calamity.HTTP.Guild - Calamity.HTTP.Interaction - Calamity.HTTP.Internal.Ratelimit - Calamity.HTTP.Internal.Request - Calamity.HTTP.Internal.Route - Calamity.HTTP.Internal.Types - Calamity.HTTP.Invite - Calamity.HTTP.MiscRoutes - Calamity.HTTP.Reason - Calamity.HTTP.User - Calamity.HTTP.Webhook - Calamity.Interactions - Calamity.Interactions.Eff - Calamity.Interactions.Utils - Calamity.Interactions.View - Calamity.Internal.BoundedStore - Calamity.Internal.ConstructorName - Calamity.Internal.IntColour - Calamity.Internal.LocalWriter - Calamity.Internal.RunIntoIO - Calamity.Internal.SnowflakeMap - Calamity.Internal.UnixTimestamp - Calamity.Internal.Updateable - Calamity.Internal.Utils - Calamity.Metrics.Eff - Calamity.Metrics.Internal - Calamity.Metrics.Noop - Calamity.Types - Calamity.Types.LogEff - Calamity.Types.Model - Calamity.Types.Model.Avatar - Calamity.Types.Model.Channel - Calamity.Types.Model.Channel.Attachment - Calamity.Types.Model.Channel.ChannelType - Calamity.Types.Model.Channel.Component - Calamity.Types.Model.Channel.DM - Calamity.Types.Model.Channel.Embed - Calamity.Types.Model.Channel.Group - Calamity.Types.Model.Channel.Guild - Calamity.Types.Model.Channel.Guild.Category - Calamity.Types.Model.Channel.Guild.Text - Calamity.Types.Model.Channel.Guild.Voice - Calamity.Types.Model.Channel.Message - Calamity.Types.Model.Channel.Reaction - Calamity.Types.Model.Channel.UpdatedMessage - Calamity.Types.Model.Channel.Webhook - Calamity.Types.Model.Guild - Calamity.Types.Model.Guild.AuditLog - Calamity.Types.Model.Guild.Ban - Calamity.Types.Model.Guild.Emoji - Calamity.Types.Model.Guild.Guild - Calamity.Types.Model.Guild.Invite - Calamity.Types.Model.Guild.Member - Calamity.Types.Model.Guild.Overwrite - Calamity.Types.Model.Guild.Permissions - Calamity.Types.Model.Guild.Role - Calamity.Types.Model.Guild.UnavailableGuild - Calamity.Types.Model.Interaction - Calamity.Types.Model.Presence - Calamity.Types.Model.Presence.Activity - Calamity.Types.Model.Presence.Presence - Calamity.Types.Model.User - Calamity.Types.Model.Voice - Calamity.Types.Model.Voice.VoiceRegion - Calamity.Types.Model.Voice.VoiceState - Calamity.Types.CDNAsset - Calamity.Types.Partial - Calamity.Types.Snowflake - Calamity.Types.Tellable - Calamity.Types.Token - Calamity.Types.TokenEff - Calamity.Types.Upgradeable - Calamity.Utils - Calamity.Utils.CDNUrl - Calamity.Utils.Colour - Calamity.Utils.Message - Calamity.Utils.Permissions - hs-source-dirs: - ./ + Calamity + Calamity.Cache.Eff + Calamity.Cache.InMemory + Calamity.Client + Calamity.Client.Client + Calamity.Client.ShardManager + Calamity.Client.Types + Calamity.Commands + Calamity.Commands.CalamityParsers + Calamity.Commands.Context + Calamity.Commands.Dsl + Calamity.Commands.Help + Calamity.Commands.Types + Calamity.Commands.Utils + Calamity.Gateway + Calamity.Gateway.DispatchEvents + Calamity.Gateway.Intents + Calamity.Gateway.Shard + Calamity.Gateway.Types + Calamity.HTTP + Calamity.HTTP.AuditLog + Calamity.HTTP.Channel + Calamity.HTTP.Emoji + Calamity.HTTP.Guild + Calamity.HTTP.Interaction + Calamity.HTTP.Internal.Ratelimit + Calamity.HTTP.Internal.Request + Calamity.HTTP.Internal.Route + Calamity.HTTP.Internal.Types + Calamity.HTTP.Invite + Calamity.HTTP.MiscRoutes + Calamity.HTTP.Reason + Calamity.HTTP.User + Calamity.HTTP.Webhook + Calamity.Interactions + Calamity.Interactions.Eff + Calamity.Interactions.Utils + Calamity.Interactions.View + Calamity.Internal.BoundedStore + Calamity.Internal.ConstructorName + Calamity.Internal.IntColour + Calamity.Internal.LocalWriter + Calamity.Internal.RunIntoIO + Calamity.Internal.SnowflakeMap + Calamity.Internal.UnixTimestamp + Calamity.Internal.Updateable + Calamity.Internal.Utils + Calamity.Metrics.Eff + Calamity.Metrics.Internal + Calamity.Metrics.Noop + Calamity.Types + Calamity.Types.CDNAsset + Calamity.Types.LogEff + Calamity.Types.Model + Calamity.Types.Model.Avatar + Calamity.Types.Model.Channel + Calamity.Types.Model.Channel.Attachment + Calamity.Types.Model.Channel.ChannelType + Calamity.Types.Model.Channel.Component + Calamity.Types.Model.Channel.DM + Calamity.Types.Model.Channel.Embed + Calamity.Types.Model.Channel.Group + Calamity.Types.Model.Channel.Guild + Calamity.Types.Model.Channel.Guild.Category + Calamity.Types.Model.Channel.Guild.Text + Calamity.Types.Model.Channel.Guild.Voice + Calamity.Types.Model.Channel.Message + Calamity.Types.Model.Channel.Reaction + Calamity.Types.Model.Channel.UpdatedMessage + Calamity.Types.Model.Channel.Webhook + Calamity.Types.Model.Guild + Calamity.Types.Model.Guild.AuditLog + Calamity.Types.Model.Guild.Ban + Calamity.Types.Model.Guild.Emoji + Calamity.Types.Model.Guild.Guild + Calamity.Types.Model.Guild.Invite + Calamity.Types.Model.Guild.Member + Calamity.Types.Model.Guild.Overwrite + Calamity.Types.Model.Guild.Permissions + Calamity.Types.Model.Guild.Role + Calamity.Types.Model.Guild.UnavailableGuild + Calamity.Types.Model.Interaction + Calamity.Types.Model.Presence + Calamity.Types.Model.Presence.Activity + Calamity.Types.Model.Presence.Presence + Calamity.Types.Model.User + Calamity.Types.Model.Voice + Calamity.Types.Model.Voice.VoiceRegion + Calamity.Types.Model.Voice.VoiceState + Calamity.Types.Partial + Calamity.Types.Snowflake + Calamity.Types.Tellable + Calamity.Types.Token + Calamity.Types.TokenEff + Calamity.Types.Upgradeable + Calamity.Utils + Calamity.Utils.CDNUrl + Calamity.Utils.Colour + Calamity.Utils.Message + Calamity.Utils.Permissions + + hs-source-dirs: ./ default-extensions: - StrictData - AllowAmbiguousTypes - BlockArguments - NoMonomorphismRestriction - BangPatterns - BinaryLiterals - UndecidableInstances - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - DerivingVia - DerivingStrategies - GeneralizedNewtypeDeriving - StandaloneDeriving - DeriveAnyClass - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - OverloadedStrings - OverloadedLabels - PartialTypeSignatures - PatternGuards - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - DuplicateRecordFields - TypeOperators - TypeApplications - RoleAnnotations - QuasiQuotes - ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing + NoMonomorphismRestriction + AllowAmbiguousTypes + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + ViewPatterns + + ghc-options: + -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall + -fno-warn-name-shadowing + build-depends: - PyF ==0.11.* - , aeson >=2.0 && <2.2 - , async >=2.2 && <3 - , base >=4.13 && <5 - , bytestring >=0.10 && <0.12 - , calamity-commands ==0.4.* - , colour >=2.3.5 && <2.4 - , concurrent-extra ==0.7.* - , connection >=0.2.6 && <0.4 - , containers ==0.6.* - , data-default-class ==0.1.* - , data-flags >=0.0.3 && <0.1 - , deepseq >=1.4.4.0 && <2 - , deque ==0.4.* - , df1 ==0.4.* - , di-core >=1.0.4 && <1.1 - , di-polysemy ==0.2.* - , exceptions ==0.10.* - , focus >=1.0 && <2 - , hashable >=1.2 && <2 - , http-api-data >=0.4.3 && <0.6 - , http-client >=0.5 && <0.8 - , http-date >=0.0.8 && <0.1 - , http-types ==0.12.* - , megaparsec >=8 && <10 - , mime-types ==0.1.* - , mtl >=2.2 && <3 - , polysemy >=1.5 && <2 - , polysemy-plugin >=0.3 && <0.5 - , reflection >=2.1 && <3 - , req >=3.9.2 && <3.14 - , safe-exceptions >=0.1 && <2 - , scientific ==0.3.* - , stm >=2.5 && <3 - , stm-chans >=3.0 && <4 - , stm-containers >=1.1 && <2 - , text >=1.2 && <2.1 - , text-show >=3.8 && <4 - , time >=1.8 && <1.13 - , tls >=1.4 && <2 - , typerep-map >=0.5 && <0.7 - , unagi-chan ==0.4.* - , unboxing-vector ==0.2.* - , unordered-containers ==0.2.* - , vector >=0.12 && <0.14 - , 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 + aeson >=2.0 && <2.2 + , aeson-optics >=1.2 && <2 + , async >=2.2 && <3 + , base >=4.13 && <5 + , bytestring >=0.10 && <0.12 + , calamity-commands >=0.4 && <0.5 + , colour >=2.3.5 && <2.4 + , concurrent-extra >=0.7 && <0.8 + , connection >=0.2.6 && <0.4 + , containers >=0.6 && <0.7 + , data-default-class >=0.1 && <0.2 + , data-flags >=0.0.3 && <0.1 + , deepseq >=1.4.4.0 && <2 + , deque >=0.4 && <0.5 + , df1 >=0.4 && <0.5 + , di-core >=1.0.4 && <1.1 + , di-polysemy >=0.2 && <0.3 + , exceptions >=0.10 && <0.11 + , focus >=1.0 && <2 + , hashable >=1.2 && <2 + , http-api-data >=0.4.3 && <0.6 + , http-client >=0.5 && <0.8 + , http-date >=0.0.8 && <0.1 + , http-types >=0.12 && <0.13 + , megaparsec >=8 && <10 + , mime-types >=0.1 && <0.2 + , mtl >=2.2 && <3 + , optics >=0.4.1 && <0.5 + , polysemy >=1.5 && <2 + , polysemy-plugin >=0.3 && <0.5 + , random >=1.2 && <1.3 + , reflection >=2.1 && <3 + , req >=3.9.2 && <3.14 + , safe-exceptions >=0.1 && <2 + , scientific >=0.3 && <0.4 + , stm >=2.5 && <3 + , stm-chans >=3.0 && <4 + , stm-containers >=1.1 && <2 + , text >=1.2 && <2.1 + , text-show >=3.8 && <4 + , time >=1.8 && <1.13 + , tls >=1.4 && <2 + , typerep-map >=0.5 && <0.7 + , unagi-chan >=0.4 && <0.5 + , unboxing-vector >=0.2 && <0.3 + , unordered-containers >=0.2 && <0.3 + , vector >=0.12 && <0.14 + , websockets >=0.12 && <0.13 + , x509-system >=1.6.6 && <1.7 + + default-language: Haskell2010