diff --git a/Calamity.hs b/Calamity.hs new file mode 100644 --- /dev/null +++ b/Calamity.hs @@ -0,0 +1,13 @@ +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 diff --git a/Calamity/Cache/Eff.hs b/Calamity/Cache/Eff.hs new file mode 100644 --- /dev/null +++ b/Calamity/Cache/Eff.hs @@ -0,0 +1,118 @@ +{-# 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 + +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 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 + GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild) + -- | Get a 'GuildChannel' from the cache + GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel) + -- | Get all 'Guild's from the cache + 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 + GetDM :: Snowflake DMChannel -> CacheEff m (Maybe DMChannel) + -- | Get all 'DMChannel's from the cache + 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 + GetUser :: Snowflake User -> CacheEff m (Maybe User) + -- | Get all 'User's from the cache + 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 + IsUnavailableGuild :: Snowflake Guild -> CacheEff m Bool + -- | Get all 'UnavailableGuild's from the cache + 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 + GetMessage :: Snowflake Message -> CacheEff m (Maybe Message) + -- | Get all 'Message's from the cache + GetMessages :: CacheEff m [Message] + -- | Delete a 'Message' from the cache + DelMessage :: Snowflake Message -> CacheEff m () + +makeSem ''CacheEff + +updateBotUser :: (P.Member CacheEff r) => (User -> User) -> Sem r () +updateBotUser f = getBotUser >>= flip whenJust (setBotUser . f) + +updateGuild :: (P.Member CacheEff r) => Snowflake Guild -> (Guild -> Guild) -> Sem r () +updateGuild id f = getGuild id >>= flip whenJust (setGuild . f) + +updateDM :: (P.Member CacheEff r) => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r () +updateDM id f = getDM id >>= flip whenJust (setDM . f) + +updateUser :: (P.Member CacheEff r) => Snowflake User -> (User -> User) -> Sem r () +updateUser id f = getUser id >>= flip whenJust (setUser . f) + +updateMessage :: (P.Member CacheEff r) => Snowflake Message -> (Message -> Message) -> Sem r () +updateMessage id f = getMessage id >>= flip whenJust (setMessage . f) diff --git a/Calamity/Cache/InMemory.hs b/Calamity/Cache/InMemory.hs new file mode 100644 --- /dev/null +++ b/Calamity/Cache/InMemory.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | A 'Cache' handler that operates in memory +module Calamity.Cache.InMemory ( + runCacheInMemory, + runCacheInMemory', + runCacheInMemoryNoMsg, +) where + +import Calamity.Cache.Eff +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 Control.Monad.State.Strict +import Data.Foldable +import Data.Functor.Identity +import Data.HashMap.Strict qualified as SH +import Data.HashSet qualified as HS +import Data.IORef +import Optics +import Optics.State.Operators ((%=), (?=)) +import Polysemy qualified as P +import Polysemy.AtomicState qualified as P + +data Cache f = Cache + { user :: Maybe User + , guilds :: !(SM.SnowflakeMap Guild) + , dms :: !(SM.SnowflakeMap DMChannel) + , guildChannels :: !(SH.HashMap (Snowflake GuildChannel) Guild) + , users :: !(SM.SnowflakeMap User) + , unavailableGuilds :: !(HS.HashSet (Snowflake Guild)) + , messages :: !(f (BS.BoundedStore Message)) + } + +$(makeFieldLabelsNoPrefix ''Cache) + +type CacheWithMsg = Cache Identity +type CacheNoMsg = Cache (Const ()) + +emptyCache :: CacheWithMsg +emptyCache = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty 1000) + +emptyCacheNoMsg :: CacheNoMsg +emptyCacheNoMsg = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Const ()) + +emptyCache' :: Int -> CacheWithMsg +emptyCache' msgLimit = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty msgLimit) + +-- | Run the cache in memory with a default message cache size of 1000 +runCacheInMemory :: (P.Member (P.Embed IO) r) => P.Sem (CacheEff ': r) a -> P.Sem r a +runCacheInMemory m = do + var <- P.embed $ newIORef emptyCache + P.runAtomicStateIORef var $ P.reinterpret runCache' m + +-- | Run the cache in memory with no messages being cached +runCacheInMemoryNoMsg :: (P.Member (P.Embed IO) r) => P.Sem (CacheEff ': r) a -> P.Sem r a +runCacheInMemoryNoMsg m = do + var <- P.embed $ newIORef emptyCacheNoMsg + P.runAtomicStateIORef var $ P.reinterpret runCache' m + +-- | Run the cache in memory with a configurable message cache limit +runCacheInMemory' :: (P.Member (P.Embed IO) r) => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a +runCacheInMemory' msgLimit m = do + var <- P.embed $ newIORef (emptyCache' msgLimit) + P.runAtomicStateIORef var $ P.reinterpret runCache' m + +runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a +runCache' act = P.atomicState' ((swap .) . runState $ runCache act) + +class MessageMod t where + setMessage' :: Message -> State t () + getMessage' :: Snowflake Message -> State t (Maybe Message) + getMessages' :: State t [Message] + delMessage' :: Snowflake Message -> State t () + +instance MessageMod CacheWithMsg where + setMessage' m = #messages % _1 %= BS.addItem m + getMessage' mid = use (#messages % _1 % at' mid) + getMessages' = toList <$> use (#messages % _1) + delMessage' mid = #messages % _1 %= sans mid + +instance MessageMod CacheNoMsg where + setMessage' !_ = pure () + getMessage' !_ = pure Nothing + getMessages' = pure [] + delMessage' !_ = pure () + +runCache :: (MessageMod (Cache t)) => CacheEff m a -> State (Cache t) a +runCache (SetBotUser u) = #user ?= u +runCache GetBotUser = use #user +runCache (SetGuild g) = do + #guilds %= SM.insert g + #guildChannels %= SH.filter (\v -> getID @Guild v /= getID @Guild g) + #guildChannels %= SH.union (SH.fromList $ map (,g) (SM.keys (g ^. #channels))) +runCache (GetGuild gid) = use (#guilds % at' gid) +runCache (GetGuildChannel cid) = use (#guildChannels % at' cid) <&> (>>= (^. #channels % at' cid)) +runCache GetGuilds = SM.elems <$> use #guilds +runCache (DelGuild gid) = do + #guilds %= sans gid + #guildChannels %= SH.filter (\v -> getID @Guild v /= gid) +runCache (SetDM dm) = #dms %= SM.insert dm +runCache (GetDM did) = use (#dms % at' did) +runCache GetDMs = SM.elems <$> use #dms +runCache (DelDM did) = #dms %= sans did +runCache (SetUser u) = #users %= SM.insert u +runCache (GetUser uid) = use (#users % at' uid) +runCache GetUsers = SM.elems <$> use #users +runCache (DelUser uid) = #users %= sans uid +runCache (SetUnavailableGuild gid) = #unavailableGuilds %= HS.insert gid +runCache (IsUnavailableGuild gid) = use (#unavailableGuilds % contains gid) +runCache GetUnavailableGuilds = HS.toList <$> use #unavailableGuilds +runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid +runCache (SetMessage m) = setMessage' m +runCache (GetMessage mid) = getMessage' mid +runCache GetMessages = getMessages' +runCache (DelMessage mid) = delMessage' mid diff --git a/Calamity/Client.hs b/Calamity/Client.hs new file mode 100644 --- /dev/null +++ b/Calamity/Client.hs @@ -0,0 +1,46 @@ +-- | Module containing the core client stuff +module Calamity.Client ( + module Calamity.Client.Client, + module Calamity.Client.Types, + + -- * Client stuff + -- $clientDocs +) where + +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 new file mode 100644 --- /dev/null +++ b/Calamity/Client/Client.hs @@ -0,0 +1,802 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | The client +module Calamity.Client.Client ( + react, + runBotIO, + runBotIO', + runBotIO'', + stopBot, + sendPresence, + events, + fire, + waitUntil, + waitUntilM, + CalamityEvent (Dispatch, ShutDown), + customEvt, +) where + +import Calamity.Cache.Eff +import Calamity.Client.ShardManager +import Calamity.Client.Types +import Calamity.Gateway.DispatchEvents +import Calamity.Gateway.Intents +import Calamity.Gateway.Types +import Calamity.HTTP.Internal.Ratelimit +import Calamity.Internal.ConstructorName +import Calamity.Internal.RunIntoIO +import Calamity.Internal.SnowflakeMap qualified as SM +import Calamity.Internal.UnixTimestamp +import Calamity.Internal.Updateable +import Calamity.Internal.Utils +import Calamity.Metrics.Eff +import Calamity.Types.LogEff +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.Presence (Presence (..)) +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice qualified as V +import Calamity.Types.Snowflake +import Calamity.Types.Token +import Calamity.Types.TokenEff +import Control.Concurrent.Chan.Unagi +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Exception (SomeException) +import Control.Monad +import Data.Default.Class +import Data.Dynamic +import Data.Foldable +import Data.IORef +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T +import Data.Time.Clock.POSIX +import Df1 qualified +import Di.Core qualified as DC +import DiPolysemy qualified as Di +import Optics +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) +timeA m = do + start <- P.embed getPOSIXTime + res <- m + end <- P.embed getPOSIXTime + let duration = fromRational . toRational $ end - start + pure (duration, res) + +newClient :: Token -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client +newClient token initialDi = do + shards' <- newTVarIO [] + numShards' <- newEmptyMVar + rlState' <- newRateLimitState + (inc, outc) <- newChan + ehidCounter <- newIORef 0 + + pure $ + Client + shards' + numShards' + token + rlState' + inc + outc + ehidCounter + initialDi + +-- | Create a bot, run your setup action, and then loop until the bot closes. +runBotIO :: + forall r a. + (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r) => + Token -> + -- | The intents the bot should use + Intents -> + P.Sem (SetupEff r) a -> + P.Sem r (Maybe StartupError) +runBotIO token intents = runBotIO' token intents Nothing + +resetDi :: (BotC r) => P.Sem r a -> P.Sem r a +resetDi m = do + initialDi <- P.asks (^. #initialDi) + Di.local (`fromMaybe` initialDi) m + +interpretRatelimitViaClient :: (P.Member (P.Reader Client) r) => P.Sem (RatelimitEff ': r) a -> P.Sem r a +interpretRatelimitViaClient = + P.interpret + ( \case + GetRatelimitState -> P.asks (^. #rlState) + ) + +interpretTokenViaClient :: (P.Member (P.Reader Client) r) => P.Sem (TokenEff ': r) a -> P.Sem r a +interpretTokenViaClient = + P.interpret + ( \case + GetBotToken -> P.asks (^. #token) + ) + +{- | Create a bot, run your setup action, and then loop until the bot closes. + + This version allows you to specify the initial status +-} +runBotIO' :: + forall r a. + (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r) => + Token -> + -- | The intents the bot should use + Intents -> + -- | The initial status to send to the gateway + Maybe StatusUpdateData -> + P.Sem (SetupEff r) a -> + P.Sem r (Maybe StartupError) +runBotIO' token intents status setup = do + initialDi <- Di.fetch + client <- P.embed $ newClient token initialDi + handlers <- P.embed $ newTVarIO def + P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . interpretTokenViaClient . interpretRatelimitViaClient . Di.push "calamity" $ do + void $ Di.push "calamity-setup" setup + r <- shardBot status intents + case r of + Left e -> pure (Just e) + Right _ -> do + Di.push "calamity-loop" clientLoop + Di.push "calamity-stop" finishUp + pure Nothing + +{- | Create a bot, run your setup action, and then loop until the bot closes. + + This version only handles the @'P.Reader' 'Client'@ effect, allowing you to + handle the @'P.AtomicState' 'EventHandlers'@ yourself. +-} +runBotIO'' :: + forall r a. + ( P.Members + '[ LogEff + , MetricEff + , CacheEff + , P.Reader Client + , P.AtomicState EventHandlers + , P.Embed IO + , P.Final IO + , P.Async + ] + r + ) => + Token -> + -- | The intents the bot should use + Intents -> + -- | The initial status to send to the gateway + Maybe StatusUpdateData -> + P.Sem (RatelimitEff ': TokenEff ': P.Reader Client ': r) a -> + P.Sem r (Maybe StartupError) +runBotIO'' token intents status setup = do + initialDi <- Di.fetch + client <- P.embed $ newClient token initialDi + P.runReader client . interpretTokenViaClient . interpretRatelimitViaClient . Di.push "calamity" $ do + void $ Di.push "calamity-setup" setup + r <- shardBot status intents + case r of + Left e -> pure (Just e) + Right _ -> do + Di.push "calamity-loop" clientLoop + Di.push "calamity-stop" finishUp + pure Nothing + +{- | Register an event handler, returning an action that removes the event handler from the bot. + + Refer to 'EventType' for what events you can register, and 'EHType' for the + parameters the event handlers they receive. + + You'll probably want @TypeApplications@ and need @DataKinds@ enabled to + specify the type of @s@. + + ==== Examples + + Reacting to every message: + + @ + 'react' @\''MessageCreateEvt' '$' \msg -> 'print' '$' "Got message: " '<>' 'show' msg + @ + + Reacting to a custom event: + + @ + data MyCustomEvt = MyCustomEvt 'Data.Text.Text' 'Message' + + 'react' @(\''CustomEvt' MyCustomEvt) $ \\(MyCustomEvt s m) -> + 'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s) + @ + + ==== Notes + + This function is pretty bad for giving nasty type errors, + since if something doesn't match then 'EHType' might not get substituted, + which will result in errors about parameter counts mismatching. +-} +react :: + forall (s :: EventType) r. + (BotC r, ReactConstraints s) => + (EHType s -> (P.Sem r) ()) -> + P.Sem r (P.Sem r ()) +react handler = do + handler' <- bindSemToIO handler + ehidC <- P.asks (^. #ehidCounter) + id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i)) + let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler') + P.atomicModify (handlers <>) + pure $ removeHandler @s id' + +removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r () +removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id') + +{- | Fire an event that the bot will then handle. + + ==== Examples + + Firing an event named \"my-event\": + + @ + 'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg) + @ +-} +fire :: (BotC r) => CalamityEvent -> P.Sem r () +fire e = do + inc <- P.asks (^. #eventsIn) + P.embed $ writeChan inc e + +{- | Build a Custom CalamityEvent + + The type of @a@ must match up with the event handler you want to receive it. + + ==== Examples + + @ + 'customEvt' (MyCustomEvent "lol") + @ +-} +customEvt :: forall a. (Typeable a) => a -> CalamityEvent +customEvt = Custom + +-- | Get a copy of the event stream. +events :: (BotC r) => P.Sem r (OutChan CalamityEvent) +events = do + inc <- P.asks (^. #eventsIn) + P.embed $ dupChan inc + +{- | Wait until an event satisfying a condition happens, then returns its + parameters. + + The check function for this command is pure unlike 'waitUntilM' + + This is what it would look like with @s ~ \''MessageCreateEvt'@: + + @ + 'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message' + @ + + And for @s ~ \''MessageUpdateEvt'@: + + @ + 'waitUntil' :: (('Message', 'Message') -> 'Bool') -> 'P.Sem' r ('Message', 'Message') + @ + + ==== Examples + + Waiting for a message containing the text \"hi\": + + @ + f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.isInfixOf' "hi" $ m ^. #content) + print $ msg ^. #content + @ +-} +waitUntil :: + forall (s :: EventType) r. + (BotC r, ReactConstraints s) => + (EHType s -> Bool) -> + P.Sem r (EHType s) +waitUntil f = P.resourceToIOFinal $ do + result <- P.embed newEmptyMVar + P.bracket + (P.raise $ react @s (checker result)) + P.raise + (const . P.embed $ takeMVar result) + where + checker :: MVar (EHType s) -> EHType s -> P.Sem r () + checker result args = do + when (f args) $ do + P.embed $ putMVar result args + +{- | Wait until an event satisfying a condition happens, then returns its + parameters + + This is what it would look like with @s ~ \''MessageCreateEvt'@: + + @ + 'waitUntilM' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message' + @ + + And for @s ~ \''MessageUpdateEvt'@: + + @ + 'waitUntilM' :: (('Message', 'Message') -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message') + @ + + ==== Examples + + Waiting for a message containing the text \"hi\": + + @ + f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.isInfixOf' "hi" $ m ^. #content)) + print $ msg ^. #content + @ +-} +waitUntilM :: + forall (s :: EventType) r. + (BotC r, ReactConstraints s) => + (EHType s -> P.Sem r Bool) -> + P.Sem r (EHType s) +waitUntilM f = P.resourceToIOFinal $ do + result <- P.embed newEmptyMVar + P.bracket + (P.raise $ react @s (checker result)) + P.raise + (const . P.embed $ takeMVar result) + where + checker :: MVar (EHType s) -> EHType s -> P.Sem r () + checker result args = do + res <- f args + when res $ do + P.embed $ putMVar result args + +-- | Set the bot's presence on all shards. +sendPresence :: (BotC r) => StatusUpdateData -> P.Sem r () +sendPresence s = do + shards <- P.asks (^. #shards) >>= P.embed . readTVarIO + for_ shards $ \(inc, _) -> + P.embed $ writeChan inc (SendPresence s) + +-- | Initiate shutting down the bot. +stopBot :: (BotC r) => P.Sem r () +stopBot = do + debug "stopping bot" + inc <- P.asks (^. #eventsIn) + P.embed $ writeChan inc ShutDown + +finishUp :: (BotC r) => P.Sem r () +finishUp = do + debug "finishing up" + shards <- P.asks (^. #shards) >>= P.embed . readTVarIO + for_ shards $ \(inc, _) -> + P.embed $ writeChan inc ShutDownShard + for_ shards $ \(_, shardThread) -> P.await shardThread + debug "bot has stopped" + +{- | main loop of the client, handles fetching the next event, processing the + event and invoking its handler functions +-} +clientLoop :: (BotC r) => P.Sem r () +clientLoop = do + outc <- P.asks (^. #eventsOut) + whileMFinalIO $ do + !evt' <- P.embed $ readChan outc + case evt' of + Dispatch !sid !evt -> handleEvent sid evt >> pure True + Custom d -> handleCustomEvent d >> pure True + ShutDown -> pure False + debug "leaving client loop" + +handleCustomEvent :: forall a r. (Typeable a, BotC r) => a -> P.Sem r () +handleCustomEvent d = do + eventHandlers <- P.atomicGet + + let handlers = getCustomEventHandlers @a eventHandlers + + for_ handlers (\h -> P.async . P.embed $ h d) + +catchAllLogging :: (BotC r) => P.Sem r () -> P.Sem r () +catchAllLogging m = do + r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m + case r of + Right _ -> pure () + Left e -> debug . T.pack $ "got exception: " <> show e + +handleEvent :: (BotC r) => Int -> DispatchData -> P.Sem r () +handleEvent shardID data' = do + debug . T.pack $ "handling an event: " <> ctorName data' + eventHandlers <- P.atomicGet + actions <- P.runFail $ do + evtCounter <- registerCounter "events_received" [("type", T.pack $ ctorName data'), ("shard", showt shardID)] + void $ addCounter 1 evtCounter + cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20 .. 100] + (time, res) <- timeA . resetDi $ handleEvent' eventHandlers data' + void $ observeHistogram time cacheUpdateHisto + pure res + + eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20 .. 100] + + case actions of + Right actions -> for_ actions $ \action -> P.async $ do + (time, _) <- timeA . catchAllLogging $ P.embed action + void $ observeHistogram time eventHandleHisto + -- pattern match failures are usually stuff like events for uncached guilds, etc + Left err -> debug . T.pack $ "Failed handling actions for event: " <> show err + +handleEvent' :: + (BotC r) => + EventHandlers -> + DispatchData -> + P.Sem (P.Fail ': r) [IO ()] +handleEvent' eh evt@(Ready rd@ReadyData {}) = do + updateCache evt + pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh) +handleEvent' _ Resumed = pure [] +handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do + updateCache evt + Just newChan <- DMChannel' <<$>> getDM (getID chan) + pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) +handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do + updateCache evt + Just guild <- getGuild (getID chan) + Just newChan <- pure $ GuildChannel' <$> guild ^. #channels % at (getID chan) + pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) +handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do + Just oldChan <- DMChannel' <<$>> getDM (getID chan) + updateCache evt + Just newChan <- DMChannel' <<$>> getDM (getID chan) + pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) +handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do + Just oldGuild <- getGuild (getID chan) + Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels % at (getID chan) + updateCache evt + Just newGuild <- getGuild (getID chan) + Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels % at (getID chan) + pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) +handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do + Just oldGuild <- getGuild (getID chan) + Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels % at (getID chan) + updateCache evt + pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) +handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do + Just oldChan <- DMChannel' <<$>> getDM (getID chan) + updateCache evt + pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) + +-- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do +-- chan <- (GuildChannel' <$> os ^? #channels % at (coerceSnowflake channelID) . _Just) +-- <|> (DMChannel' <$> os ^? #dms % at (coerceSnowflake channelID) . _Just) +-- pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh) + +handleEvent' eh evt@(GuildCreate guild) = do + isNew <- not <$> isUnavailableGuild (getID guild) + updateCache evt + Just guild <- getGuild (getID guild) + pure $ + map + ($ (guild, if isNew then GuildCreateNew else GuildCreateAvailable)) + (getEventHandlers @'GuildCreateEvt eh) +handleEvent' eh evt@(GuildUpdate guild) = do + Just oldGuild <- getGuild (getID guild) + updateCache evt + Just newGuild <- getGuild (getID guild) + pure $ map ($ (oldGuild, newGuild)) (getEventHandlers @'GuildUpdateEvt eh) + +-- NOTE: Guild will be deleted in the new cache if unavailable was false +handleEvent' eh evt@(GuildDelete UnavailableGuild {id, unavailable}) = do + Just oldGuild <- getGuild id + updateCache evt + pure $ + map + ($ (oldGuild, if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved)) + (getEventHandlers @'GuildDeleteEvt eh) +handleEvent' eh evt@(GuildBanAdd BanData {guildID, user}) = do + Just guild <- getGuild guildID + updateCache evt + pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanAddEvt eh) +handleEvent' eh evt@(GuildBanRemove BanData {guildID, user}) = do + Just guild <- getGuild guildID + updateCache evt + pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanRemoveEvt eh) + +-- NOTE: we fire this event using the guild data with old emojis +handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData {guildID, emojis}) = do + Just guild <- getGuild guildID + updateCache evt + pure $ map ($ (guild, emojis)) (getEventHandlers @'GuildEmojisUpdateEvt eh) +handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData {guildID}) = do + updateCache evt + Just guild <- getGuild guildID + pure $ map ($ guild) (getEventHandlers @'GuildIntegrationsUpdateEvt eh) +handleEvent' eh evt@(GuildMemberAdd gid member) = do + updateCache evt + Just guild <- getGuild gid + Just member <- pure $ guild ^. #members % at (getID member) + pure $ map ($ (guild, member)) (getEventHandlers @'GuildMemberAddEvt eh) +handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData {user, guildID}) = do + Just guild <- getGuild guildID + Just member <- pure $ guild ^. #members % at (getID user) + updateCache evt + pure $ map ($ (guild, member)) (getEventHandlers @'GuildMemberRemoveEvt eh) +handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData {user, guildID}) = do + Just oldGuild <- getGuild guildID + Just oldMember <- pure $ oldGuild ^. #members % at (getID user) + updateCache evt + Just newGuild <- getGuild guildID + Just newMember <- pure $ newGuild ^. #members % at (getID user) + pure $ map ($ (newGuild, oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) +handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData {members, guildID}) = do + updateCache evt + Just guild <- getGuild guildID + let memberIDs = map (getID @Member) members + let members' = mapMaybe (\mid -> guild ^. #members % at mid) memberIDs + pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh) +handleEvent' eh evt@(GuildRoleCreate GuildRoleData {guildID, role}) = do + updateCache evt + Just guild <- getGuild guildID + Just role' <- pure $ guild ^. #roles % at (getID role) + pure $ map ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh) +handleEvent' eh evt@(GuildRoleUpdate GuildRoleData {guildID, role}) = do + Just oldGuild <- getGuild guildID + Just oldRole <- pure $ oldGuild ^. #roles % at (getID role) + updateCache evt + Just newGuild <- getGuild guildID + Just newRole <- pure $ newGuild ^. #roles % at (getID role) + pure $ map ($ (newGuild, oldRole, newRole)) (getEventHandlers @'GuildRoleUpdateEvt eh) +handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData {guildID, roleID}) = do + Just guild <- getGuild guildID + Just role <- pure $ guild ^. #roles % at roleID + updateCache evt + pure $ map ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh) +handleEvent' eh (InviteCreate d) = do + pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh) +handleEvent' eh (InviteDelete d) = do + pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh) +handleEvent' eh evt@(MessageCreate msg user member) = do + updateCache evt + pure $ map ($ (msg, user, member)) (getEventHandlers @'MessageCreateEvt eh) +handleEvent' eh evt@(MessageUpdate msg user member) = do + oldMsg <- getMessage (getID msg) + updateCache evt + newMsg <- getMessage (getID msg) + let rawActions = map ($ (msg, user, member)) (getEventHandlers @'RawMessageUpdateEvt eh) + let actions = case (oldMsg, newMsg) of + (Just oldMsg', Just newMsg') -> + map ($ (oldMsg', newMsg', user, member)) (getEventHandlers @'MessageUpdateEvt eh) + _ -> [] + pure $ rawActions <> actions +handleEvent' eh evt@(MessageDelete MessageDeleteData {id}) = do + oldMsg <- getMessage id + updateCache evt + let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh) + let actions = case oldMsg of + Just oldMsg' -> + map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh) + _ -> [] + pure $ rawActions <> actions +handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData {ids}) = do + messages <- catMaybes <$> traverse getMessage ids + updateCache evt + let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh) + let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh) + pure $ rawActions <> actions +handleEvent' eh evt@(MessageReactionAdd reaction) = do + updateCache evt + msg <- getMessage (getID reaction) + user <- getUser (getID reaction) + chan <- case reaction ^. #guildID of + Just _ -> do + chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction) + pure (GuildChannel' <$> chan) + Nothing -> do + chan <- getDM (coerceSnowflake $ getID @Channel reaction) + pure (DMChannel' <$> chan) + let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh) + let actions = case (msg, user, chan) of + (Just msg', Just user', Just chan') -> + map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionAddEvt eh) + _ -> [] + pure $ rawActions <> actions +handleEvent' eh evt@(MessageReactionRemove reaction) = do + msg <- getMessage (getID reaction) + updateCache evt + user <- getUser (getID reaction) + chan <- case reaction ^. #guildID of + Just _ -> do + chan <- getGuildChannel (coerceSnowflake $ getID @Channel reaction) + pure (GuildChannel' <$> chan) + Nothing -> do + chan <- getDM (coerceSnowflake $ getID @Channel reaction) + pure (DMChannel' <$> chan) + let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh) + let actions = case (msg, user, chan) of + (Just msg', Just user', Just chan') -> + map ($ (msg', user', chan', reaction ^. #emoji)) (getEventHandlers @'MessageReactionRemoveEvt eh) + _ -> [] + pure $ rawActions <> actions +handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) = do + msg <- getMessage messageID + updateCache evt + let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh) + let actions = case msg of + Just msg' -> + map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh) + _ -> [] + pure $ rawActions <> actions +handleEvent' eh evt@(PresenceUpdate PresenceUpdateData {userID, presence = Presence {guildID}}) = do + Just oldGuild <- getGuild guildID + Just oldMember <- pure $ oldGuild ^. #members % at (coerceSnowflake userID) + updateCache evt + Just newGuild <- getGuild guildID + Just newMember <- pure $ newGuild ^. #members % at (coerceSnowflake userID) + let oldUser :: User = let Member {..} = oldMember in User {..} + newUser :: User = let Member {..} = newMember in User {..} + userUpdates = + if oldUser /= newUser + then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh) + else mempty + pure $ userUpdates <> map ($ (newGuild, oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) +handleEvent' eh (TypingStart TypingStartData {channelID, guildID, userID, timestamp = UnixTimestamp timestamp}) = + case guildID of + Just gid -> do + Just guild <- getGuild gid + Just chan <- pure $ GuildChannel' <$> guild ^. #channels % at (coerceSnowflake channelID) + pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh) + Nothing -> do + Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID) + pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh) +handleEvent' eh evt@(UserUpdate _) = do + Just oldUser <- getBotUser + updateCache evt + Just newUser <- getBotUser + pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh) +handleEvent' eh evt@(VoiceStateUpdate newVoiceState@V.VoiceState {guildID = Just guildID}) = do + oldVoiceState <- ((find ((== V.sessionID newVoiceState) . V.sessionID) . voiceStates) =<<) <$> getGuild guildID + updateCache evt + pure $ map ($ (oldVoiceState, newVoiceState)) (getEventHandlers @'VoiceStateUpdateEvt eh) +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 () +updateCache (Ready ReadyData {user, guilds}) = do + setBotUser user + for_ (map getID guilds) setUnavailableGuild +updateCache Resumed = pure () +updateCache (ChannelCreate (DMChannel' chan)) = + setDM chan +updateCache (ChannelCreate (GuildChannel' chan)) = + updateGuild (getID chan) (#channels %~ SM.insert chan) +updateCache (ChannelUpdate (DMChannel' chan)) = + updateDM (getID chan) (update chan) +updateCache (ChannelUpdate (GuildChannel' chan)) = + updateGuild (getID chan) (#channels % ix (getID chan) %~ update chan) +updateCache (ChannelDelete (DMChannel' chan)) = + delDM (getID chan) +updateCache (ChannelDelete (GuildChannel' chan)) = + updateGuild (getID chan) (#channels %~ sans (getID chan)) +updateCache (GuildCreate guild) = do + isNew <- isUnavailableGuild (getID guild) + when isNew $ delUnavailableGuild (getID guild) + setGuild guild + for_ (SM.elems (guild ^. #members)) (\Member {..} -> setUser User {..}) +updateCache (GuildUpdate guild) = + updateGuild (getID guild) (update guild) +updateCache (GuildDelete UnavailableGuild {id, unavailable}) = + if unavailable + then setUnavailableGuild id + else delGuild id +updateCache (GuildEmojisUpdate GuildEmojisUpdateData {guildID, emojis}) = + updateGuild guildID (#emojis .~ SM.fromList emojis) +updateCache (GuildMemberAdd gid member) = do + setUser $ (\Member {..} -> User {..}) member + updateGuild gid (#members % at (getID member) ?~ member) +updateCache (GuildMemberRemove GuildMemberRemoveData {guildID, user}) = + updateGuild guildID (#members %~ sans (getID user)) +updateCache (GuildMemberUpdate GuildMemberUpdateData {guildID, roles = AesonVector roles, user, nick}) = do + setUser user + updateGuild guildID (#members % ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) +updateCache (GuildMembersChunk GuildMembersChunkData {guildID, members}) = + traverse_ (updateCache . GuildMemberAdd guildID) members +updateCache (GuildRoleCreate GuildRoleData {guildID, role}) = + updateGuild guildID (#roles %~ SM.insert role) +updateCache (GuildRoleUpdate GuildRoleData {guildID, role}) = + updateGuild guildID (#roles %~ SM.insert role) +updateCache (GuildRoleDelete GuildRoleDeleteData {guildID, roleID}) = + updateGuild guildID (#roles %~ sans roleID) +updateCache (MessageCreate !msg !user !_) = do + setMessage msg + whenJust user $ \u -> + setUser u +updateCache (MessageUpdate msg !_ !_) = + updateMessage (getID msg) (update msg) +updateCache (MessageDelete MessageDeleteData {id}) = delMessage id +updateCache (MessageDeleteBulk MessageDeleteBulkData {ids}) = + for_ ids delMessage +updateCache (MessageReactionAdd reaction) = do + isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser + updateMessage + (getID reaction) + ( \m -> + case m ^. #reactions & filter ((== (reaction ^. #emoji)) . (^. #emoji)) of + [] -> m & #reactions %~ (<> [Reaction 1 isMe (reaction ^. #emoji)]) + _ -> + m & #reactions % traversed %~ updateReactionAdd isMe (reaction ^. #emoji) + ) +updateCache (MessageReactionRemove reaction) = do + isMe <- (\u -> Just (getID @User reaction) == (getID @User <$> u)) <$> getBotUser + updateMessage + (getID reaction) + ( \m -> + m + & #reactions + % traversed + %~ updateReactionRemove isMe (reaction ^. #emoji) + & #reactions + %~ filter (\r -> r ^. #count /= 0) + ) +updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData {messageID}) = + updateMessage messageID (#reactions .~ mempty) +updateCache (PresenceUpdate PresenceUpdateData {userID, presence}) = + updateGuild (getID presence) (#presences % at userID ?~ presence) +updateCache (UserUpdate user) = setBotUser user +-- we don't handle group channels currently +updateCache (ChannelCreate (GroupChannel' _)) = pure () +updateCache (ChannelUpdate (GroupChannel' _)) = pure () +updateCache (ChannelDelete (GroupChannel' _)) = pure () +-- these don't modify state +updateCache (GuildBanAdd _) = pure () +updateCache (GuildBanRemove _) = pure () +updateCache (GuildIntegrationsUpdate _) = pure () +updateCache (TypingStart _) = pure () +updateCache (ChannelPinsUpdate _) = pure () +updateCache (WebhooksUpdate _) = pure () +updateCache (InviteCreate _) = pure () +updateCache (InviteDelete _) = pure () +updateCache (VoiceStateUpdate voiceState@V.VoiceState {guildID = Just guildID}) = + updateGuild guildID (#voiceStates %~ updateVoiceStates) + where + updateVoiceStates [] = [voiceState] + updateVoiceStates (x : xs) + | V.sessionID x == V.sessionID voiceState = voiceState : xs + | otherwise = x : updateVoiceStates xs + +-- we don't handle voice server update and direct voice connections currently +updateCache (VoiceStateUpdate V.VoiceState {guildID = Nothing}) = pure () +updateCache (VoiceServerUpdate _) = pure () +-- 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 + & #me + %~ (|| isMe) + else reaction + +updateReactionRemove :: Bool -> RawEmoji -> Reaction -> Reaction +updateReactionRemove isMe emoji reaction = + if emoji == reaction ^. #emoji + then + reaction + & #count + %~ pred + & #me + %~ (&& not isMe) + else reaction diff --git a/Calamity/Client/ShardManager.hs b/Calamity/Client/ShardManager.hs new file mode 100644 --- /dev/null +++ b/Calamity/Client/ShardManager.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | Contains stuff for managing shards +module Calamity.Client.ShardManager (shardBot) where + +import Calamity.Client.Types +import Calamity.Gateway +import Calamity.HTTP +import Calamity.Internal.Utils +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Monad +import Data.Text qualified as T +import Data.Traversable +import Optics +import Polysemy (Sem) +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 +mapLeft _ (Right b) = Right b + +-- | Connects the bot to the gateway over n shards +shardBot :: (BotC r) => Maybe StatusUpdateData -> Intents -> Sem r (Either StartupError ()) +shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do + numShardsVar <- P.asks numShards + shardsVar <- P.asks shards + + hasShards <- P.embed $ not . null <$> readTVarIO shardsVar + when hasShards $ fail "don't use shardBot on an already running bot." + + token <- P.asks Calamity.Client.Types.token + inc <- P.asks (^. #eventsIn) + + Right gateway <- invoke GetGatewayBot + + let numShards' = gateway ^. #shards + let host = gateway ^. #url + P.embed $ putMVar numShardsVar numShards' + + info . T.pack $ "Number of shards: " <> show numShards' + + shards <- for [0 .. numShards' - 1] $ \id -> + newShard host id numShards' token initialStatus intents inc + + P.embed . atomically $ writeTVar shardsVar shards diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs new file mode 100644 --- /dev/null +++ b/Calamity/Client/Types.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Types for the client +module Calamity.Client.Types ( + Client (..), + StartupError (..), + EventType (..), + GuildCreateStatus (..), + GuildDeleteStatus (..), + EHType, + BotC, + SetupEff, + ReactConstraints, + EventHandlers (..), + InsertEventHandler (..), + RemoveEventHandler (..), + getEventHandlers, + getCustomEventHandlers, +) where + +import Calamity.Cache.Eff +import Calamity.Gateway.DispatchEvents (CalamityEvent (..), InviteCreateData, InviteDeleteData, ReactionEvtData, ReadyData) +import Calamity.Gateway.Types (ControlMessage) +import Calamity.HTTP.Internal.Ratelimit +import Calamity.HTTP.Internal.Types +import Calamity.Metrics.Eff +import Calamity.Types.LogEff +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.UpdatedMessage +import Calamity.Types.Model.Guild +import Calamity.Types.Model.Interaction (Interaction) +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice +import Calamity.Types.Snowflake +import Calamity.Types.Token +import Calamity.Types.TokenEff +import Control.Concurrent.Async +import Control.Concurrent.Chan.Unagi +import Control.Concurrent.MVar +import Control.Concurrent.STM.TVar +import Data.Default.Class +import Data.Dynamic +import Data.IORef +import Data.Kind (Type) +import Data.Maybe +import Data.Time +import Data.TypeRepMap (TypeRepMap, WrapTypeable (..)) +import Data.TypeRepMap qualified as TM +import Data.Typeable +import Data.Void (Void) +import Df1 qualified +import Di.Core qualified as DC +import GHC.Exts (fromList) +import Optics.TH +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 ()))] + , numShards :: MVar Int + , token :: Token + , rlState :: RateLimitState + , eventsIn :: InChan CalamityEvent + , eventsOut :: OutChan CalamityEvent + , ehidCounter :: IORef Integer + , initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message) + } + +-- | Constraints required by the bot client +type BotC r = + ( P.Members + '[ LogEff + , MetricEff + , CacheEff + , RatelimitEff + , TokenEff + , P.Reader Client + , P.AtomicState EventHandlers + , P.Embed IO + , P.Final IO + , P.Async + ] + r + ) + +-- | A concrete effect stack used inside the bot +type SetupEff r = (RatelimitEff ': TokenEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) + +{- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't + worry about these since they are satisfied for any type @s@ can be +-} +type ReactConstraints s = + ( InsertEventHandler s + , RemoveEventHandler s + ) + +newtype StartupError = StartupError String + deriving stock (Show) + +-- | A Data Kind used to fire custom events +data EventType + = ReadyEvt + | ChannelCreateEvt + | ChannelUpdateEvt + | ChannelDeleteEvt + | ChannelpinsUpdateEvt + | GuildCreateEvt + | GuildUpdateEvt + | GuildDeleteEvt + | GuildBanAddEvt + | GuildBanRemoveEvt + | GuildEmojisUpdateEvt + | GuildIntegrationsUpdateEvt + | GuildMemberAddEvt + | GuildMemberRemoveEvt + | GuildMemberUpdateEvt + | GuildMembersChunkEvt + | GuildRoleCreateEvt + | GuildRoleUpdateEvt + | GuildRoleDeleteEvt + | InviteCreateEvt + | InviteDeleteEvt + | MessageCreateEvt + | -- | Fired when a cached message is updated, use 'RawMessageUpdateEvt' to see + -- updates of uncached messages + MessageUpdateEvt + | -- | Fired when a message is updated + RawMessageUpdateEvt + | -- | Fired when a cached message is deleted, use 'RawMessageDeleteEvt' to see + -- deletes of uncached messages. + -- + -- Does not include messages deleted through bulk deletes, use + -- 'MessageDeleteBulkEvt' for those + MessageDeleteEvt + | -- | Fired when a message is deleted. + -- + -- Does not include messages deleted through bulk deletes, use + -- 'RawMessageDeleteBulkEvt' for those + RawMessageDeleteEvt + | -- | Fired when messages are bulk deleted. Only includes cached messages, use + -- 'RawMessageDeleteBulkEvt' to see deletes of uncached messages. + MessageDeleteBulkEvt + | -- | Fired when messages are bulk deleted. + RawMessageDeleteBulkEvt + | -- | Fired when a reaction is added to a cached message, use + -- 'RawMessageReactionAddEvt' to see reactions on uncached messages. + MessageReactionAddEvt + | -- | Fired when a reaction is added to a message. + RawMessageReactionAddEvt + | -- | Fired when a reaction is removed from a cached message, use + -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages. + MessageReactionRemoveEvt + | -- | Fired when a reaction is removed from a message. + RawMessageReactionRemoveEvt + | -- | Fired when all reactions are removed from a cached message, use + -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages. + -- + -- The message passed will contain the removed events. + MessageReactionRemoveAllEvt + | -- | Fired when all reactions are removed from a message. + RawMessageReactionRemoveAllEvt + | TypingStartEvt + | UserUpdateEvt + | -- | Sent when someone joins/leaves/moves voice channels + VoiceStateUpdateEvt + | -- | Fired when the bot receives an interaction + InteractionEvt + | -- | A custom event, @a@ is the data sent to the handler and should probably + -- be a newtype to disambiguate events + forall (a :: Type). CustomEvt a + +data GuildCreateStatus + = -- | The guild was just joined + GuildCreateNew + | -- | The guild is becoming available + GuildCreateAvailable + deriving (Show) + +data GuildDeleteStatus + = -- | The guild became unavailable + GuildDeleteUnavailable + | -- | The bot was removed from the guild + GuildDeleteRemoved + deriving (Show) + +{- | A type family to decide what the parameters for an event handler should be + determined by the type of event it is handling. +-} +type family EHType (d :: EventType) where + EHType 'ReadyEvt = ReadyData + EHType 'ChannelCreateEvt = Channel + EHType 'ChannelUpdateEvt = (Channel, Channel) + EHType 'ChannelDeleteEvt = Channel + EHType 'ChannelpinsUpdateEvt = (Channel, Maybe UTCTime) + EHType 'GuildCreateEvt = (Guild, GuildCreateStatus) + EHType 'GuildUpdateEvt = (Guild, Guild) + EHType 'GuildDeleteEvt = (Guild, GuildDeleteStatus) + EHType 'GuildBanAddEvt = (Guild, User) + EHType 'GuildBanRemoveEvt = (Guild, User) + EHType 'GuildEmojisUpdateEvt = (Guild, [Emoji]) + EHType 'GuildIntegrationsUpdateEvt = Guild + EHType 'GuildMemberAddEvt = (Guild, Member) + EHType 'GuildMemberRemoveEvt = (Guild, Member) + EHType 'GuildMemberUpdateEvt = (Guild, Member, Member) + EHType 'GuildMembersChunkEvt = (Guild, [Member]) + EHType 'GuildRoleCreateEvt = (Guild, Role) + EHType 'GuildRoleUpdateEvt = (Guild, Role, Role) + EHType 'GuildRoleDeleteEvt = (Guild, Role) + EHType 'InviteCreateEvt = InviteCreateData + EHType 'InviteDeleteEvt = InviteDeleteData + EHType 'MessageCreateEvt = (Message, Maybe User, Maybe Member) + EHType 'MessageUpdateEvt = (Message, Message, Maybe User, Maybe Member) + EHType 'MessageDeleteEvt = Message + EHType 'MessageDeleteBulkEvt = [Message] + EHType 'MessageReactionAddEvt = (Message, User, Channel, RawEmoji) + EHType 'MessageReactionRemoveEvt = (Message, User, Channel, RawEmoji) + EHType 'MessageReactionRemoveAllEvt = Message + EHType 'RawMessageUpdateEvt = (UpdatedMessage, Maybe User, Maybe Member) + EHType 'RawMessageDeleteEvt = Snowflake Message + EHType 'RawMessageDeleteBulkEvt = [Snowflake Message] + EHType 'RawMessageReactionAddEvt = ReactionEvtData + EHType 'RawMessageReactionRemoveEvt = ReactionEvtData + EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message + EHType 'TypingStartEvt = (Channel, Snowflake User, UTCTime) + EHType 'UserUpdateEvt = (User, User) + EHType 'VoiceStateUpdateEvt = (Maybe VoiceState, VoiceState) + EHType 'InteractionEvt = Interaction + EHType ('CustomEvt a) = a + +type StoredEHType t = EHType t -> IO () + +newtype EventHandlers = EventHandlers (TypeRepMap EventHandler) + +data EventHandlerWithID (a :: Type) = EventHandlerWithID + { ehID :: Integer + , eh :: a + } + +newtype CustomEHTypeStorage (a :: Type) = CustomEHTypeStorage + { unwrapCustomEHTypeStorage :: [EventHandlerWithID (a -> IO ())] + } + deriving newtype (Monoid, Semigroup) + +type family EHStorageType (t :: EventType) where + EHStorageType ('CustomEvt _) = TypeRepMap CustomEHTypeStorage + EHStorageType t = [EventHandlerWithID (StoredEHType t)] + +newtype EventHandler (t :: EventType) = EH + { unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t + } + +instance Semigroup (EventHandler t) where + EH a <> EH b = EH $ a <> b + +instance Monoid (EventHandler t) where + mempty = EH mempty + +instance Default EventHandlers where + def = + EventHandlers $ + fromList + [ WrapTypeable $ EH @'ReadyEvt [] + , WrapTypeable $ EH @'ChannelCreateEvt [] + , WrapTypeable $ EH @'ChannelUpdateEvt [] + , WrapTypeable $ EH @'ChannelDeleteEvt [] + , WrapTypeable $ EH @'ChannelpinsUpdateEvt [] + , WrapTypeable $ EH @'GuildCreateEvt [] + , WrapTypeable $ EH @'GuildUpdateEvt [] + , WrapTypeable $ EH @'GuildDeleteEvt [] + , WrapTypeable $ EH @'GuildBanAddEvt [] + , WrapTypeable $ EH @'GuildBanRemoveEvt [] + , WrapTypeable $ EH @'GuildEmojisUpdateEvt [] + , WrapTypeable $ EH @'GuildIntegrationsUpdateEvt [] + , WrapTypeable $ EH @'GuildMemberAddEvt [] + , WrapTypeable $ EH @'GuildMemberRemoveEvt [] + , WrapTypeable $ EH @'GuildMemberUpdateEvt [] + , WrapTypeable $ EH @'GuildMembersChunkEvt [] + , WrapTypeable $ EH @'GuildRoleCreateEvt [] + , WrapTypeable $ EH @'GuildRoleUpdateEvt [] + , WrapTypeable $ EH @'GuildRoleDeleteEvt [] + , WrapTypeable $ EH @'MessageCreateEvt [] + , WrapTypeable $ EH @'MessageUpdateEvt [] + , WrapTypeable $ EH @'MessageDeleteEvt [] + , WrapTypeable $ EH @'MessageDeleteBulkEvt [] + , WrapTypeable $ EH @'MessageReactionAddEvt [] + , WrapTypeable $ EH @'MessageReactionRemoveEvt [] + , WrapTypeable $ EH @'MessageReactionRemoveAllEvt [] + , WrapTypeable $ EH @'TypingStartEvt [] + , WrapTypeable $ EH @'UserUpdateEvt [] + , WrapTypeable $ EH @'InteractionEvt [] + , WrapTypeable $ EH @('CustomEvt Void) TM.empty + ] + +instance Semigroup EventHandlers where + (EventHandlers a) <> (EventHandlers b) = EventHandlers $ TM.unionWith (<>) a b + +instance Monoid EventHandlers where + mempty = def + +-- not sure what to think of this + +type family EHInstanceSelector (d :: EventType) :: Bool where + EHInstanceSelector ('CustomEvt _) = 'True + EHInstanceSelector _ = 'False + +{- | A helper typeclass that is used to decide how to register regular + events, and custom events which require storing in a map at runtime. +-} +class InsertEventHandler (a :: EventType) where + makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers + +instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a) => InsertEventHandler a where + makeEventHandlers = makeEventHandlers' (Proxy @flag) + +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 + makeEventHandlers' _ _ id' handler = + EventHandlers . TM.one $ + 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 + makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @s [EventHandlerWithID id' handler] + +class GetEventHandlers a where + getEventHandlers :: EventHandlers -> [StoredEHType a] + +instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a) => GetEventHandlers a where + getEventHandlers = getEventHandlers' (Proxy @a) (Proxy @flag) + +class GetEventHandlers' (flag :: Bool) a where + getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a] + +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 + getEventHandlers' _ _ (EventHandlers handlers) = + let theseHandlers = unwrapEventHandler @s $ fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler s)) + in map eh theseHandlers + +class RemoveEventHandler a where + removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers + +instance (EHInstanceSelector a ~ flag, RemoveEventHandler' flag a) => RemoveEventHandler a where + removeEventHandler = removeEventHandler' (Proxy @flag) + +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 + removeEventHandler' _ _ id' (EventHandlers handlers) = + EventHandlers $ + TM.adjust @('CustomEvt Void) + ( \(EH ehs) -> + EH + ( TM.adjust @a + (CustomEHTypeStorage . filter ((/= id') . ehID) . unwrapCustomEHTypeStorage) + ehs + ) + ) + handlers + +instance + (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => + RemoveEventHandler' 'False s + where + removeEventHandler' _ _ id' (EventHandlers handlers) = + EventHandlers $ + TM.adjust @s + (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs) + handlers + +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))) + in maybe mempty (map eh . unwrapCustomEHTypeStorage) $ TM.lookup @a handlerMap + +$(makeFieldLabelsNoPrefix ''Client) diff --git a/Calamity/Commands.hs b/Calamity/Commands.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands.hs @@ -0,0 +1,99 @@ +{- | Calamity commands + 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, + + -- * Commands + -- $commandDocs +) where + +import Calamity.Commands.CalamityParsers () +import Calamity.Commands.Dsl +import Calamity.Commands.Help +import Calamity.Commands.Types +import Calamity.Commands.Utils +import CalamityCommands.Error +import CalamityCommands.Parser + +{- $commandDocs + + This module provides abstractions for writing declarative commands, that + support grouping, pre-invokation checks, and automatic argument parsing by + using a type level list of parameter types. + + A DSL is provided in "Calamity.Commands.Dsl" for constructing commands + declaratively. + + You can implement 'ParameterParser' for your own types to allow them to be used + in the parameter list of commands. + + A default help command is provided in "Calamity.Commands.Help" which can be + added just by using 'helpCommand' inside the command declaration DSL. + + This module is pretty much a wrapper/re-export of the package + "CalamityCommands", look there for more documentation. + + To decide which context type you want to use, and how the command prefix + should be parsed, you need to handle the following effects: + + 1. 'CalamityCommands.ParsePrefix.ParsePrefix' + + Handles parsing prefixes, the + 'Calamity.Commands.Utils.useConstantPrefix' function handles constant + prefixes. + + 2. 'CalamityCommands.Context.ConstructContext' + + Handles constructing the context and also decides which context is + going to be used, calamity offers + 'Calamity.Commands.Context.useFullContext' which makes the context + 'Calamity.Commands.Context.FullContext', and + 'Calamity.Commands.Context.useLightContext' which makes the context + 'Calamity.Commands.Context.LightContext'. + + ==== Custom Events + + The event handler registered by 'addCommands' will fire the following custom events: + + 1. 'Calamity.Commands.Utils.CtxCommandError' + + Fired when a command returns an error. + + 2. 'Calamity.Commands.Utils.CommandNotFound' + + Fired when a valid prefix is used, but the command is not found. + + 3. 'Calamity.Commands.Utils.CommandInvoked' + + Fired when a command is successfully invoked. + + + ==== Registered Metrics + + 1. Counter: @"commands_invoked" [name]@ + + Incremented on each command invokation, the parameter @name@ is the + path/name of the invoked command. + + + ==== Examples + + An example of using commands: + + @ + 'addCommands' $ do + 'helpCommand' + 'command' \@\'['Calamity.Types.Model.User.User'] "utest" $ \\ctx u \-\> do + 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx $ "got user: " '<>' 'TextShow.showt' u + 'group' "admin" $ do + 'command' \@'[] "bye" $ \\ctx -> do + 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx "bye!" + 'Calamity.Client.stopBot' + @ +-} diff --git a/Calamity/Commands/CalamityParsers.hs b/Calamity/Commands/CalamityParsers.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands/CalamityParsers.hs @@ -0,0 +1,219 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | 'ParameterParser' instances for calamity models +module Calamity.Commands.CalamityParsers () where + +import Calamity.Cache.Eff +import Calamity.Commands.Context +import Calamity.Types.Model.Channel (Channel, GuildChannel) +import Calamity.Types.Model.Guild (Emoji, Guild, Member, Partial (PartialEmoji), RawEmoji (..), Role) +import Calamity.Types.Model.User (User) +import Calamity.Types.Partial +import Calamity.Types.Snowflake +import CalamityCommands.ParameterInfo +import CalamityCommands.Parser +import Control.Monad +import Control.Monad.Trans (lift) +import Data.Maybe (fromMaybe, isJust) +import Data.Text qualified as T +import Data.Typeable +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) + +parserName :: forall a c r. (ParameterParser a c r) => T.Text +parserName = + let ParameterInfo (fromMaybe "" -> name) type_ _ = parameterInfo @a @c @r + in name <> ":" <> T.pack (show type_) + +instance (Typeable (Snowflake a)) => ParameterParser (Snowflake a) c r where + parse = parseMP (parserName @(Snowflake a)) snowflake + parameterDescription = "discord id" + +-- | Accepts both plain IDs and mentions +instance {-# OVERLAPS #-} ParameterParser (Snowflake User) c r where + parse = parseMP (parserName @(Snowflake User)) (try (ping "@") <|> snowflake) + parameterDescription = "user mention or id" + +-- | Accepts both plain IDs and mentions +instance {-# OVERLAPS #-} ParameterParser (Snowflake Member) c r where + parse = parseMP (parserName @(Snowflake Member)) (try (ping "@") <|> snowflake) + parameterDescription = "user mention or id" + +-- | Accepts both plain IDs and mentions +instance {-# OVERLAPS #-} ParameterParser (Snowflake Channel) c r where + parse = parseMP (parserName @(Snowflake Channel)) (try (ping "#") <|> snowflake) + parameterDescription = "channel mention or id" + +-- | Accepts both plain IDs and mentions +instance {-# OVERLAPS #-} ParameterParser (Snowflake Role) c r where + parse = parseMP (parserName @(Snowflake Role)) (try (ping "@&") <|> snowflake) + parameterDescription = "role mention or id" + +-- | Accepts both plain IDs and uses of emoji +instance {-# OVERLAPS #-} ParameterParser (Snowflake Emoji) c r where + parse = parseMP (parserName @(Snowflake Emoji)) (try emoji <|> snowflake) + parameterDescription = "emoji or id" + +mapParserMaybeM :: (Monad m, Stream s) => ParsecT SpannedError s m a -> T.Text -> (a -> m (Maybe b)) -> ParsecT SpannedError s m b +mapParserMaybeM m e f = do + offs <- getOffset + r <- m >>= lift . f + offe <- getOffset + case r of + Just r' -> pure r' + Nothing -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe + +{- | ParameterParser for members in the guild the command was invoked in, this only looks + in the cache. Use @'Snowflake' 'Member'@ and use + 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +-} +instance (P.Member CacheEff r, CalamityCommandContext c) => ParameterParser Member c r where + parse = + parseMP (parserName @Member @c @r) $ + mapParserMaybeM + (try (ping "@") <|> snowflake) + "Couldn't find a Member with this id" + ( \mid -> do + ctx <- P.ask + guild <- join <$> getGuild `traverse` ctxGuildID ctx + pure $ guild ^? _Just % #members % ix mid + ) + parameterDescription = "user mention or id" + +{- | ParameterParser for users, this only looks in the cache. Use @'Snowflake' + 'User'@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow + fetching from http. +-} +instance (P.Member CacheEff r) => ParameterParser User c r where + parse = + parseMP (parserName @User @c @r) $ + mapParserMaybeM + (try (ping "@") <|> snowflake) + "Couldn't find a User with this id" + getUser + parameterDescription = "user mention or id" + +{- | ParameterParser for channels in the guild the command was invoked in, this only + looks in the cache. Use @'Snowflake' 'Channel'@ and use + 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +-} +instance (P.Member CacheEff r, CalamityCommandContext c) => ParameterParser GuildChannel c r where + parse = + parseMP (parserName @GuildChannel @c @r) $ + mapParserMaybeM + (try (ping "#") <|> snowflake) + "Couldn't find a GuildChannel with this id" + ( \cid -> do + ctx <- P.ask + guild <- join <$> getGuild `traverse` ctxGuildID ctx + pure $ guild ^? _Just % #channels % ix cid + ) + parameterDescription = "channel mention or id" + +{- | ParameterParser for guilds, this only looks in the cache. Use @'Snowflake' 'Guild'@ + and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching + from http. +-} +instance (P.Member CacheEff r) => ParameterParser Guild c r where + parse = + parseMP (parserName @Guild @c @r) $ + mapParserMaybeM + snowflake + "Couldn't find a Guild with this id" + getGuild + parameterDescription = "guild id" + +{- | ParameterParser for emojis in the guild the command was invoked in, this only + looks in the cache. Use @'Snowflake' 'Emoji'@ and use + 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +-} +instance (P.Member CacheEff r, CalamityCommandContext c) => ParameterParser Emoji c r where + parse = + parseMP (parserName @Emoji @c @r) $ + mapParserMaybeM + (try emoji <|> snowflake) + "Couldn't find an Emoji with this id" + ( \eid -> do + ctx <- P.ask + guild <- join <$> getGuild `traverse` ctxGuildID ctx + pure $ guild ^? _Just % #emojis % ix eid + ) + parameterDescription = "emoji or id" + +-- | 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 + parameterDescription = "emoji" + +{- | ParameterParser for roles in the guild the command was invoked in, this only + looks in the cache. Use @'Snowflake' 'Role'@ and use + 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. +-} +instance (P.Member CacheEff r, CalamityCommandContext c) => ParameterParser Role c r where + parse = + parseMP (parserName @Role @c @r) $ + mapParserMaybeM + (try (ping "@&") <|> snowflake) + "Couldn't find an Emoji with this id" + ( \rid -> do + ctx <- P.ask + guild <- join <$> getGuild `traverse` ctxGuildID ctx + pure $ guild ^? _Just % #roles % ix rid + ) + parameterDescription = "role mention or id" + +-- skipN :: (Stream s, Ord e) => Int -> ParsecT e s m () +-- skipN n = void $ takeP Nothing n + +ping :: (MonadParsec e T.Text m) => T.Text -> m (Snowflake a) +ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">" + +ping' :: (MonadParsec e T.Text m) => m () -> m (Snowflake a) +ping' m = chunk "<" *> m *> snowflake <* chunk ">" + +snowflake :: (MonadParsec e T.Text m) => m (Snowflake a) +snowflake = Snowflake <$> decimal + +partialEmoji :: (MonadParsec e T.Text m) => m (Partial Emoji) +partialEmoji = do + animated <- isJust <$> (chunk "<" *> optional (chunk "a")) + name <- between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") (/= ':')) + id <- snowflake + void $ chunk ">" + pure (PartialEmoji id name animated) + +emoji :: (MonadParsec e T.Text m) => m (Snowflake a) +emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing (/= ':'))) + +-- trackOffsets :: MonadParsec e s m => m a -> m (a, Int) +-- trackOffsets m = do +-- offs <- getOffset +-- a <- m +-- offe <- getOffset +-- pure (a, offe - offs) + +-- item :: MonadParsec e L.Text m => m L.Text +-- item = try quotedString <|> someNonWS + +-- manySingle :: MonadParsec e s m => m (Tokens s) +-- manySingle = takeWhileP (Just "Any character") (const True) + +-- someSingle :: MonadParsec e s m => m (Tokens s) +-- someSingle = takeWhile1P (Just "any character") (const True) + +-- quotedString :: MonadParsec e L.Text m => m L.Text +-- quotedString = try (between (chunk "'") (chunk "'") (takeWhileP (Just "any character") (/= '\''))) <|> +-- between (chunk "\"") (chunk "\"") (takeWhileP (Just "any character") (/= '"')) + +-- -- manyNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s) +-- -- manyNonWS = takeWhileP (Just "Any Non-Whitespace") (not . isSpace) + +-- someNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s) +-- someNonWS = takeWhile1P (Just "any non-whitespace") (not . isSpace) diff --git a/Calamity/Commands/Context.hs b/Calamity/Commands/Context.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands/Context.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Command invokation context +module Calamity.Commands.Context ( + CalamityCommandContext (..), + FullContext (..), + useFullContext, + LightContext (..), + useLightContext, +) where + +import Calamity.Cache.Eff +import Calamity.Commands.Types +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.Types.Tellable +import CalamityCommands.Context qualified as CC +import Control.Applicative +import Control.Monad +import Data.Text qualified as T +import Optics +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 + ctxChannelID :: c -> Snowflake Channel + + -- | The id of the guild the command was invoked in, if in a guild + ctxGuildID :: c -> Maybe (Snowflake Guild) + + -- | The id of the user that invoked this command + ctxUserID :: c -> Snowflake User + + -- | The message that triggered this command + ctxMessage :: c -> Message + +-- | Invokation context for commands +data FullContext = FullContext + { 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 + deriving (HasID Channel) via HasIDField "channel" FullContext + deriving (HasID Message) via HasIDField "message" FullContext + deriving (HasID User) via HasIDField "user" FullContext + +$(makeFieldLabelsNoPrefix ''FullContext) + +instance CC.CommandContext IO FullContext () where + ctxPrefix = (^. #prefix) + ctxCommand = (^. #command) + ctxUnparsedParams = (^. #unparsedParams) + +instance CalamityCommandContext FullContext where + ctxChannelID = getID . (^. #channel) + ctxGuildID c = getID <$> c ^. #guild + ctxUserID = getID . (^. #user) + ctxMessage = (^. #message) + +instance Tellable FullContext where + getChannel = pure . ctxChannelID + +useFullContext :: (P.Member CacheEff r) => P.Sem (CC.ConstructContext (Message, User, Maybe Member) FullContext IO () ': r) a -> P.Sem r a +useFullContext = + P.interpret + ( \case + CC.ConstructContext (pre, cmd, up) (msg, usr, mem) -> buildContext msg usr mem pre cmd up + ) + +buildContext :: (P.Member CacheEff r) => Message -> User -> Maybe Member -> T.Text -> Command FullContext -> T.Text -> P.Sem r (Maybe FullContext) +buildContext msg usr mem prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do + guild <- join <$> getGuild `traverse` (msg ^. #guildID) + let member = mem <|> guild ^? _Just % #members % ix (coerceSnowflake $ getID @User msg) + let gchan = guild ^? _Just % #channels % ix (coerceSnowflake $ getID @Channel msg) + Just channel <- case gchan of + Just chan -> pure . pure $ GuildChannel' chan + Nothing -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg) + + pure $ FullContext msg guild member channel usr command prefix unparsed + +-- | A lightweight context that doesn't need any cache information +data LightContext = LightContext + { 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 + deriving (HasID Channel) via HasIDField "channelID" LightContext + deriving (HasID Message) via HasIDField "message" LightContext + deriving (HasID User) via HasIDField "user" LightContext + +$(makeFieldLabelsNoPrefix ''LightContext) + +instance CC.CommandContext IO LightContext () where + ctxPrefix = (^. #prefix) + ctxCommand = (^. #command) + ctxUnparsedParams = (^. #unparsedParams) + +instance CalamityCommandContext LightContext where + ctxChannelID = (^. #channelID) + ctxGuildID = (^. #guildID) + ctxUserID = (^. #user % #id) + ctxMessage = (^. #message) + +instance Tellable LightContext where + getChannel = pure . ctxChannelID + +useLightContext :: P.Sem (CC.ConstructContext (Message, User, Maybe Member) LightContext IO () ': r) a -> P.Sem r a +useLightContext = + P.interpret + ( \case + CC.ConstructContext (pre, cmd, up) (msg, usr, mem) -> + pure . Just $ LightContext msg (msg ^. #guildID) (msg ^. #channelID) usr mem cmd pre up + ) diff --git a/Calamity/Commands/Dsl.hs b/Calamity/Commands/Dsl.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands/Dsl.hs @@ -0,0 +1,330 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +{- | A DSL for generating commands and groups + + This is effectively just a re-export of "CalamityCommands.Dsl" but with + documentation more tuned for usage with Calamity. +-} +module Calamity.Commands.Dsl ( + -- * Commands DSL + -- $dslTutorial + command, + command', + commandA, + commandA', + hide, + help, + requires, + requires', + requiresPure, + group, + group', + groupA, + groupA', + DSLState, + fetchHandler, +) where + +import CalamityCommands.Dsl qualified as CC +import CalamityCommands.ParameterInfo + +import Calamity.Commands.Types + +import Data.Text qualified as T + +import CalamityCommands.CommandUtils (CommandForParsers, TypedCommandC) +import CalamityCommands.Context qualified as CC +import CalamityCommands.Error (CommandError) +import Polysemy qualified as P +import Polysemy.Fail qualified as P +import Polysemy.Reader qualified as P +import Polysemy.Tagged qualified as P + +{- $dslTutorial + + This module provides a way of constructing bot commands in a declarative way. + + The main component of this is the 'Calamity.Commands.Dsl.command' function, + which takes a type-level list of command parameters, the name, and the callback + and produces a command. There are also the alternatives + 'Calamity.Commands.Dsl.command'', 'commandA' and 'commandA'', for when you want + to handle parsing of the input yourself, and/or want aliases of the command. + + The functions: 'hide', 'help', 'requires', and 'group' can be used to change + attributes of any commands declared inside the monadic action passed to them, + for example: + + @ + 'hide' '$' do + 'Calamity.Commands.Dsl.command' \@'[] "test" \\ctx -> 'pure' () + @ + + In the above block, any command declared inside 'hide' will have its + \'hidden\' flag set and will not be shown by the default help command: + 'Calamity.Commands.Help.helpCommand' + + The 'Calamity.Commands.Help.helpCommand' function can be used to create a + help command for the commands DSL action it is used in, read its doc page + for more information on how it functions. + + The 'Calamity.Commands.Utils.addCommands' function creates the command + handler for the commands registered in the passed action, it is what reads a + message to determine what command was invoked. It should be used to register the + commands with the bot by using it inside the setup action, for example: + + @ + 'Calamity.Client.runBotIO' ('Calamity.BotToken' token) + $ 'Calamity.Commands.Utils.addCommands' $ do + 'Calamity.Commands.Help.helpCommand' + 'Calamity.Commands.Dsl.command' \@'[] "test" \\ctx -> + 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' \@'T.Text' ctx "hi" + @ + + The above block will create a command with no parameters named \'test\', + along with a help command. +-} + +{- | Given the command name and parameter names, @parser@ and @callback@ for a + command in the 'P.Sem' monad, build a command by transforming the Polysemy + actions into IO actions. Then register the command. + + The parent group, visibility, checks, and command help are drawn from the + reader context. +-} +command' :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the command + T.Text -> + -- | The command's parameters + [ParameterInfo] -> + -- | The parser for this command + (c -> P.Sem r (Either CommandError a)) -> + -- | The callback for this command + ((c, a) -> P.Sem (P.Fail ': r) ()) -> + P.Sem r (Command c) +command' = CC.command' + +{- | Given the command name, aliases, and parameter names, @parser@ and + @callback@ for a command in the 'P.Sem' monad, build a command by + transforming the Polysemy actions into IO actions. Then register the command. + + The parent group, visibility, checks, and command help are drawn from the + reader context. +-} +commandA' :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the command + T.Text -> + -- | The aliases for the command + [T.Text] -> + -- | The command's parameters + [ParameterInfo] -> + -- | The parser for this command + (c -> P.Sem r (Either CommandError a)) -> + -- | The callback for this command + ((c, a) -> P.Sem (P.Fail ': r) ()) -> + P.Sem r (Command c) +commandA' = CC.commandA' + +{- | Given the name of a command and a callback, and a type level list of + the parameters, build and register a command. + + The parent group, visibility, checks, and command help are drawn from the + reader context. + + Command parameters are parsed by first invoking + 'CalamityCommands.Parser.parse' for the first + 'CalamityCommands.Parser.ParameterParser', then running the next parser on the + remaining input, and so on. + + ==== Examples + + Building a command that bans a user by id. + + @ + 'Calamity.Commands.Dsl.command' \@\'['CalamityCommands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), + 'CalamityCommands.Parser.Named' "reason" ('CalamityCommands.Parser.KleeneStarConcat' 'T.Text')] + "ban" $ \\ctx uid r -> case (ctx 'Optics.^.' #guild) of + 'Just' guild -> do + 'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r) + 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) + 'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'T.Text' ctx "Can only ban users from guilds." + @ +-} +command :: + forall ps c r. + ( P.Member (P.Final IO) r + , DSLC c r + , CC.CommandContext IO c () + , TypedCommandC ps c () r + ) => + -- | The name of the command + T.Text -> + -- | The callback for this command + (c -> CommandForParsers ps r ()) -> + P.Sem r (Command c) +command = CC.command @ps + +{- | Given the name and aliases of a command and a callback, and a type level list of + the parameters, build and register a command. + + The parent group, visibility, checks, and command help are drawn from the + reader context. + + ==== Examples + + Building a command that bans a user by id. + + @ + 'commandA' \@\'['CalamityCommands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), + 'CalamityCommands.Parser.Named' "reason" ('CalamityCommands.Parser.KleeneStarConcat' 'T.Text')] + "ban" [] $ \\ctx uid r -> case (ctx 'Optics.^.' #guild) of + 'Just' guild -> do + 'Control.Monad.void' . 'Calamity.HTTP.invoke' $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid ('Calamity.HTTP.Guild.CreateGuildBanData' 'Nothing' $ 'Just' r) + 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) + 'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'T.Text' ctx "Can only ban users from guilds." + @ +-} +commandA :: + forall ps c r. + ( P.Member (P.Final IO) r + , DSLC c r + , CC.CommandContext IO c () + , TypedCommandC ps c () r + ) => + -- | The name of the command + T.Text -> + -- | The aliases for the command + [T.Text] -> + -- | The callback for this command + (c -> CommandForParsers ps r ()) -> + P.Sem r (Command c) +commandA = CC.commandA @ps + +{- | Set the visibility of any groups or commands registered inside the given + action to hidden. +-} +hide :: + (P.Member (P.Tagged "hidden" (P.Reader Bool)) r) => + P.Sem r a -> + P.Sem r a +hide = CC.hide + +-- | Set the help for any groups or commands registered inside the given action. +help :: + (P.Member (P.Reader (c -> T.Text)) r) => + (c -> T.Text) -> + P.Sem r a -> + P.Sem r a +help = CC.help + +{- | Add to the list of checks for any commands registered inside the given + action. +-} +requires :: + (DSLC c r) => + [Check c] -> + P.Sem r a -> + P.Sem r a +requires = CC.requires + +{- | Construct a check and add it to the list of checks for any commands + registered inside the given action. + + Refer to 'CalamityCommands.Check.Check' for more info on checks. +-} +requires' :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the check + T.Text -> + -- | The callback for the check + (c -> P.Sem r (Maybe T.Text)) -> + P.Sem r a -> + P.Sem r a +requires' = CC.requires' + +{- | Construct some pure checks and add them to the list of checks for any + commands registered inside the given action. + + Refer to 'CalamityCommands.Check.Check' for more info on checks. +-} +requiresPure :: + (DSLC c r) => + [(T.Text, c -> Maybe T.Text)] -> + -- A list of check names and check callbacks + P.Sem r a -> + P.Sem r a +requiresPure = CC.requiresPure + +{- | Construct a group and place any commands registered in the given action + into the new group. + + This also resets the @help@ function back to its original value, use + 'group'' if you don't want that (i.e. your help function is context aware). +-} +group :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the group + T.Text -> + P.Sem r a -> + P.Sem r a +group = CC.group + +{- | Construct a group with aliases and place any commands registered in the + given action into the new group. + + The parent group, visibility, checks, and command help are drawn from the + reader context. + + This also resets the @help@ function back to its original value, use + 'group'' if you don't want that (i.e. your help function is context aware). +-} +groupA :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the group + T.Text -> + -- | The aliases of the group + [T.Text] -> + P.Sem r a -> + P.Sem r a +groupA = CC.groupA + +{- | Construct a group and place any commands registered in the given action + into the new group. + + The parent group, visibility, checks, and command help are drawn from the + reader context. + + Unlike 'help' this doesn't reset the @help@ function back to its original + value. +-} +group' :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the group + T.Text -> + P.Sem r a -> + P.Sem r a +group' = CC.group' + +{- | Construct a group with aliases and place any commands registered in the given action + into the new group. + + The parent group, visibility, checks, and command help are drawn from the + reader context. + + Unlike 'help' this doesn't reset the @help@ function back to its original + value. +-} +groupA' :: + (P.Member (P.Final IO) r, DSLC c r) => + -- | The name of the group + T.Text -> + -- | The aliases of the group + [T.Text] -> + P.Sem r a -> + P.Sem r a +groupA' = CC.groupA' + +-- | Retrieve the final command handler for this block +fetchHandler :: (DSLC c r) => P.Sem r (CommandHandler c) +fetchHandler = P.ask diff --git a/Calamity/Commands/Help.hs b/Calamity/Commands/Help.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands/Help.hs @@ -0,0 +1,70 @@ +-- | A default help command implementation +module Calamity.Commands.Help ( + helpCommand', + helpCommand, +) where + +import Calamity.Client.Types (BotC) +import Calamity.Commands.Types +import Calamity.Types.Tellable +import CalamityCommands.Help qualified as CC +import Control.Monad (void) +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 + groups in the passed 'CommandHandler'. +-} +helpCommand' :: (Tellable c, BotC r, CommandContext c) => CommandHandler c -> Maybe (Group c) -> [Check c] -> P.Sem r (Command c) +helpCommand' handler parent checks = CC.helpCommand' handler parent checks (\a b -> void $ tell a b) + +{- | Create and register the default help command for all the commands registered + in the commands DSL this is used in. The @render@ parameter is used so you can + determine how the help should be rendered, for example it could be + @'putStrLn'@, or a pure function such as @'pure' . 'Left'@ + + The registered command will have the name \'help\', called with no parameters + it will render help for the top-level groups and commands, for example: + + @ + The following groups exist: + - reanimate + - prefix[prefixes] + - alias[aliases] + - remind[reminder|reminders] + + The following commands exist: + - help :[Text] + @ + + Both commands and groups are listed in the form: @\[\|\]@, + commands also have their parameter list shown. + + If a path to a group is passed, the help, aliases, and pre-invokation checks + will be listed, along with the subgroups and commands, For example: + + @ + Help for group remind: + Group: remind + Aliases: reminder reminders + Commands related to making reminders + + The following child commands exist: + - list + - remove reminder_id:Text + - add :KleenePlusConcat Text + @ + + If a command path is passed, the usage, checks and help for the command are + shown, for example: + + @ + Help for command add: + Usage: c!prefix add prefix:Text + Checks: prefixLimit guildOnly + + Add a new prefix + @ +-} +helpCommand :: (Tellable c, BotC r, CommandContext c) => P.Sem (DSLState c r) (Command c) +helpCommand = CC.helpCommand (\a b -> void $ tell a b) diff --git a/Calamity/Commands/Types.hs b/Calamity/Commands/Types.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands/Types.hs @@ -0,0 +1,29 @@ +{- | "CalamityCommands" types with their types filled in + + If you're importing "CalamityCommands" make sure these get used instead of + the more generic variants. +-} +module Calamity.Commands.Types ( + type Command, + type Group, + type CommandHandler, + type Check, + type DSLState, + type DSLC, + type CommandContext, +) where + +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 () +type CommandHandler c = CC.CommandHandler IO c () +type Check c = CC.Check IO c +type DSLState c r = CC.DSLState IO c () r +type DSLC c r = CC.DSLC IO c () r +type CommandContext c = CC.CommandContext IO c () diff --git a/Calamity/Commands/Utils.hs b/Calamity/Commands/Utils.hs new file mode 100644 --- /dev/null +++ b/Calamity/Commands/Utils.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Command handler utilities +module Calamity.Commands.Utils ( + addCommands, + useConstantPrefix, + CmdInvokeFailReason (..), + CtxCommandError (..), + CommandNotFound (..), + CommandInvoked (..), +) where + +import Calamity.Client.Client +import Calamity.Client.Types +import Calamity.Commands.Dsl +import Calamity.Commands.Types +import Calamity.Metrics.Eff +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Member (Member) +import Calamity.Types.Model.User (User) +import CalamityCommands.CommandUtils +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 Data.Text qualified as T +import Data.Typeable +import Optics.TH (makeFieldLabelsNoPrefix) +import Polysemy qualified as P + +data CmdInvokeFailReason c + = NoContext + | NotFound [T.Text] + | CommandInvokeError c CC.CommandError + +data CtxCommandError c = CtxCommandError + { ctx :: c + , err :: CC.CommandError + } + deriving (Show) + +data CommandNotFound = CommandNotFound + { msg :: Message + , user :: User + , member :: Maybe Member + , path :: [T.Text] + -- ^ The groups that were successfully parsed + } + deriving (Show) + +newtype CommandInvoked c = CommandInvoked + { ctx :: c + } + deriving stock (Show) + +-- | A default interpretation for 'CC.ParsePrefix' that uses a single constant prefix. +useConstantPrefix :: T.Text -> P.Sem (CC.ParsePrefix Message ': r) a -> P.Sem r a +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) +addCommands m = do + (handler, res) <- CC.buildCommands m + remove <- react @'MessageCreateEvt $ \case + (msg, Just user, member) -> do + CC.parsePrefix msg >>= \case + Just (prefix, cmd) -> do + 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 + 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) + +$(makeFieldLabelsNoPrefix ''CmdInvokeFailReason) +$(makeFieldLabelsNoPrefix ''CtxCommandError) +$(makeFieldLabelsNoPrefix ''CommandNotFound) +$(makeFieldLabelsNoPrefix ''CommandInvoked) diff --git a/Calamity/Gateway.hs b/Calamity/Gateway.hs new file mode 100644 --- /dev/null +++ b/Calamity/Gateway.hs @@ -0,0 +1,24 @@ +module Calamity.Gateway ( + module Calamity.Gateway.Shard, + module Calamity.Gateway.Types, + module Calamity.Gateway.Intents, + + -- * Gateway + -- $gatewayDocs +) where + +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 new file mode 100644 --- /dev/null +++ b/Calamity/Gateway/DispatchEvents.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | module containing all dispatch events +module Calamity.Gateway.DispatchEvents where + +import Calamity.Internal.ConstructorName +import Calamity.Internal.UnixTimestamp +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.UpdatedMessage +import Calamity.Types.Model.Guild.Ban +import Calamity.Types.Model.Guild.Emoji +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.Guild.UnavailableGuild +import Calamity.Types.Model.Interaction +import Calamity.Types.Model.Presence.Presence +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Kind (Type) +import Data.Text (Text) +import Data.Time +import Data.Typeable (Typeable) +import GHC.Generics +import Optics.TH + +data CalamityEvent + = Dispatch + -- | The shard that pushed this event + Int + -- | The attached data + DispatchData + | -- | The data sent to the custom event + forall (a :: Type). (Typeable a) => Custom a + | ShutDown + +data DispatchData + = Ready !ReadyData + | Resumed + | ChannelCreate !Channel + | ChannelUpdate !Channel + | ChannelDelete !Channel + | ChannelPinsUpdate !ChannelPinsUpdateData + | GuildCreate !Guild + | GuildUpdate !UpdatedGuild + | GuildDelete !UnavailableGuild + | GuildBanAdd !BanData + | GuildBanRemove !BanData + | GuildEmojisUpdate !GuildEmojisUpdateData + | GuildIntegrationsUpdate !GuildIntegrationsUpdateData + | GuildMemberAdd !(Snowflake Guild) !Member + | GuildMemberRemove !GuildMemberRemoveData + | GuildMemberUpdate !GuildMemberUpdateData + | GuildMembersChunk !GuildMembersChunkData + | GuildRoleCreate !GuildRoleData + | GuildRoleUpdate !GuildRoleData + | GuildRoleDelete !GuildRoleDeleteData + | InviteCreate !InviteCreateData + | InviteDelete !InviteDeleteData + | MessageCreate !Message !(Maybe User) !(Maybe Member) + | MessageUpdate !UpdatedMessage !(Maybe User) !(Maybe Member) + | MessageDelete !MessageDeleteData + | MessageDeleteBulk !MessageDeleteBulkData + | MessageReactionAdd !ReactionEvtData + | MessageReactionRemove !ReactionEvtData + | MessageReactionRemoveAll !MessageReactionRemoveAllData + | PresenceUpdate !PresenceUpdateData + | TypingStart !TypingStartData + | UserUpdate !User + | VoiceStateUpdate !VoiceState + | VoiceServerUpdate !VoiceServerUpdateData + | WebhooksUpdate !WebhooksUpdateData + | InteractionCreate !Interaction + | UNHANDLED Text + deriving (Show, Generic, CtorName) + +data ReadyData = ReadyData + { v :: Integer + , user :: User + , guilds :: [UnavailableGuild] + , sessionID :: Text + } + deriving (Show) + +instance Aeson.FromJSON ReadyData where + parseJSON = Aeson.withObject "ReadyData" $ \v -> + ReadyData + <$> v .: "v" + <*> v .: "user" + <*> v .: "guilds" + <*> v .: "session_id" + +data ChannelPinsUpdateData = ChannelPinsUpdateData + { channelID :: Snowflake Channel + , lastPinTimestamp :: Maybe UTCTime + } + deriving (Show) + +instance Aeson.FromJSON ChannelPinsUpdateData where + parseJSON = Aeson.withObject "ChannelPinsUpdateData" $ \v -> + ChannelPinsUpdateData + <$> v .: "channel_id" + <*> v .: "last_pin_timestamp" + +data GuildEmojisUpdateData = GuildEmojisUpdateData + { guildID :: Snowflake Guild + , emojis :: [Emoji] + } + deriving (Show) + +instance Aeson.FromJSON GuildEmojisUpdateData where + parseJSON = Aeson.withObject "GuildEmojisUpdateData" $ \v -> + GuildEmojisUpdateData + <$> v .: "guild_id" + <*> v .: "emojis" + +newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData + { guildID :: Snowflake Guild + } + deriving stock (Show) + +instance Aeson.FromJSON GuildIntegrationsUpdateData where + parseJSON = Aeson.withObject "GuildIntegrationsUpdateData" $ \v -> + GuildIntegrationsUpdateData + <$> v .: "guild_id" + +data GuildMemberRemoveData = GuildMemberRemoveData + { guildID :: Snowflake Guild + , user :: User + } + deriving (Show) + +instance Aeson.FromJSON GuildMemberRemoveData where + parseJSON = Aeson.withObject "GuildMemberRemoveData" $ \v -> + GuildMemberRemoveData + <$> v .: "guild_id" + <*> v .: "user" + +data GuildMemberUpdateData = GuildMemberUpdateData + { guildID :: Snowflake Guild + , roles :: AesonVector (Snowflake Role) + , user :: User + , nick :: Maybe Text + } + deriving (Show) + +instance Aeson.FromJSON GuildMemberUpdateData where + parseJSON = Aeson.withObject "GuildMemberUpdateData" $ \v -> + GuildMemberUpdateData + <$> v .: "guild_id" + <*> v .: "roles" + <*> v .: "user" + <*> v .:? "nick" + +data GuildMembersChunkData = GuildMembersChunkData + { guildID :: Snowflake Guild + , members :: [Member] + } + deriving (Show) + +instance Aeson.FromJSON GuildMembersChunkData where + parseJSON = Aeson.withObject "GuildMembersChunkData" $ \v -> do + guildID <- v Aeson..: "guild_id" + + members' <- do + members' <- v Aeson..: "members" + traverse (Aeson.parseJSON . Aeson.Object) members' + + pure $ GuildMembersChunkData guildID members' + +data GuildRoleData = GuildRoleData + { guildID :: Snowflake Guild + , role :: Role + } + deriving (Show) + +instance Aeson.FromJSON GuildRoleData where + parseJSON = Aeson.withObject "GuildRoleData" $ \v -> + GuildRoleData + <$> v .: "guild_id" + <*> v .: "role" + +data GuildRoleDeleteData = GuildRoleDeleteData + { guildID :: Snowflake Guild + , roleID :: Snowflake Role + } + deriving (Show) +instance Aeson.FromJSON GuildRoleDeleteData where + parseJSON = Aeson.withObject "GuildRoleDeleteData" $ \v -> + GuildRoleDeleteData + <$> v .: "guild_id" + <*> v .: "role_id" + +data InviteCreateData = InviteCreateData + { channelID :: Snowflake Channel + , code :: Text + , createdAt :: UTCTime + , guildID :: Maybe (Snowflake Guild) + , inviter :: Maybe (Snowflake User) + , maxAge :: Int + , maxUses :: Int + , targetUser :: Maybe (Snowflake User) + , targetUserType :: Maybe Integer + , temporary :: Bool + , uses :: Integer + } + deriving (Show) + +instance Aeson.FromJSON InviteCreateData where + parseJSON = Aeson.withObject "InviteCreateData" $ \v -> do + let inviter = (v .:? "inviter") >>= traverse (.: "id") + targetUser = (v .:? "target_user") >>= traverse (.: "id") + + InviteCreateData + <$> v .: "channel_id" + <*> v .: "code" + <*> v .: "created_at" + <*> v .:? "guild_id" + <*> inviter + <*> v .: "max_age" + <*> v .: "max_uses" + <*> targetUser + <*> v .:? "target_user_type" + <*> v .: "temporary" + <*> v .: "uses" + +data InviteDeleteData = InviteDeleteData + { channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , code :: Text + } + deriving (Show) + +instance Aeson.FromJSON InviteDeleteData where + parseJSON = Aeson.withObject "InviteDeleteData" $ \v -> + InviteDeleteData + <$> v .: "channel_id" + <*> v .:? "guild_id" + <*> v .: "code" + +data MessageDeleteData = MessageDeleteData + { id :: Snowflake Message + , channelID :: Snowflake Channel + , guildID :: Snowflake Guild + } + deriving (Show) + +instance Aeson.FromJSON MessageDeleteData where + parseJSON = Aeson.withObject "MessageDeleteData" $ \v -> + MessageDeleteData + <$> v .: "id" + <*> v .: "channel_id" + <*> v .: "guild_id" + +data MessageDeleteBulkData = MessageDeleteBulkData + { guildID :: Snowflake Guild + , channelID :: Snowflake Channel + , ids :: [Snowflake Message] + } + deriving (Show) + +instance Aeson.FromJSON MessageDeleteBulkData where + parseJSON = Aeson.withObject "MessageDeleteBulkData" $ \v -> + MessageDeleteBulkData + <$> v .: "guild_id" + <*> v .: "channel_id" + <*> v .: "ids" + +data MessageReactionRemoveAllData = MessageReactionRemoveAllData + { channelID :: Snowflake Channel + , messageID :: Snowflake Message + , guildID :: Maybe (Snowflake Guild) + } + deriving (Show) + +instance Aeson.FromJSON MessageReactionRemoveAllData where + parseJSON = Aeson.withObject "MessageReactionRemoveAllData" $ \v -> + MessageReactionRemoveAllData + <$> v .: "channel_id" + <*> v .: "message_id" + <*> v .: "guild_id" + +data PresenceUpdateData = PresenceUpdateData + { userID :: Snowflake User + , presence :: Presence + } + deriving (Show) + +instance Aeson.FromJSON PresenceUpdateData where + parseJSON = Aeson.withObject "PresenceUpdate" $ \v -> do + user <- (v Aeson..: "user") >>= (Aeson..: "id") + presence <- Aeson.parseJSON $ Aeson.Object v + pure $ PresenceUpdateData user presence + +data TypingStartData = TypingStartData + { channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , userID :: Snowflake User + , timestamp :: UnixTimestamp + } + deriving (Show) + +instance Aeson.FromJSON TypingStartData where + parseJSON = Aeson.withObject "TypingStartData" $ \v -> + TypingStartData + <$> v .: "channel_id" + <*> v .: "guild_id" + <*> v .: "user_id" + <*> v .: "timestamp" + +newtype VoiceServerUpdateData = VoiceServerUpdateData Aeson.Value + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Aeson.FromJSON) + +newtype WebhooksUpdateData = WebhooksUpdateData Aeson.Value + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Aeson.FromJSON) + +data ReactionEvtData = ReactionEvtData + { userID :: Snowflake User + , channelID :: Snowflake Channel + , messageID :: Snowflake Message + , guildID :: Maybe (Snowflake Guild) + , emoji :: RawEmoji + } + deriving (Eq, Show) + deriving (HasID User) via HasIDField "userID" ReactionEvtData + deriving (HasID Channel) via HasIDField "channelID" ReactionEvtData + deriving (HasID Message) via HasIDField "messageID" ReactionEvtData + +instance Aeson.FromJSON ReactionEvtData where + parseJSON = Aeson.withObject "ReactionEvtData" $ \v -> + ReactionEvtData + <$> v .: "user_id" + <*> v .: "channel_id" + <*> v .: "message_id" + <*> v .: "guild_id" + <*> v .: "emoji" + +$(makeFieldLabelsNoPrefix ''ReadyData) +$(makeFieldLabelsNoPrefix ''ReactionEvtData) diff --git a/Calamity/Gateway/Intents.hs b/Calamity/Gateway/Intents.hs new file mode 100644 --- /dev/null +++ b/Calamity/Gateway/Intents.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoDeriveAnyClass #-} + +-- | Discord gateway intents +module Calamity.Gateway.Intents ( + Intents (..), + defaultIntents, + intentGuilds, + intentGuildMembers, + intentGuildBans, + intentGuildEmojis, + intentGuildIntegrations, + intentGuildWebhooks, + intentGuildInvites, + intentGuildVoiceStates, + intentGuildPresences, + intentGuildMessages, + intentGuildMessageReactions, + intentGuildMessageTyping, + intentDirectMessages, + intentDirectMessageReactions, + intentDirectMessageTyping, +) where + +import Data.Aeson (ToJSON) +import Data.Bits (Bits (shiftL)) +import Data.Default.Class (Default (..)) +import Data.Flags (allBut, (.+.)) +import Data.Flags.TH (bitmaskWrapper) +import Data.Word (Word32) + +$( bitmaskWrapper + "Intents" + ''Word32 + [] + [ ("intentGuilds", 1 `shiftL` 0) + , ("intentGuildMembers", 1 `shiftL` 1) + , ("intentGuildBans", 1 `shiftL` 2) + , ("intentGuildEmojis", 1 `shiftL` 3) + , ("intentGuildIntegrations", 1 `shiftL` 4) + , ("intentGuildWebhooks", 1 `shiftL` 5) + , ("intentGuildInvites", 1 `shiftL` 6) + , ("intentGuildVoiceStates", 1 `shiftL` 7) + , ("intentGuildPresences", 1 `shiftL` 8) + , ("intentGuildMessages", 1 `shiftL` 9) + , ("intentGuildMessageReactions", 1 `shiftL` 10) + , ("intentGuildMessageTyping", 1 `shiftL` 11) + , ("intentDirectMessages", 1 `shiftL` 12) + , ("intentDirectMessageReactions", 1 `shiftL` 13) + , ("intentDirectMessageTyping", 1 `shiftL` 14) + , ("intentGuildScheduledEvents", 1 `shiftL` 16) + ] + ) + +deriving via Word32 instance ToJSON Intents + +-- | Default intents are all but the privileged intents: members and intents +defaultIntents :: Intents +defaultIntents = allBut (intentGuildMembers .+. intentGuildPresences) + +-- | Default intents are all but the privileged intents: members and intents +instance Default Intents where + def = defaultIntents diff --git a/Calamity/Gateway/Shard.hs b/Calamity/Gateway/Shard.hs new file mode 100644 --- /dev/null +++ b/Calamity/Gateway/Shard.hs @@ -0,0 +1,408 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | The shard logic +module Calamity.Gateway.Shard ( + Shard (..), + newShard, +) where + +import Calamity.Gateway.DispatchEvents ( + CalamityEvent (Dispatch), + DispatchData (Ready), + ) +import Calamity.Gateway.Intents (Intents) +import Calamity.Gateway.Types ( + ControlMessage (..), + IdentifyData ( + IdentifyData, + compress, + intents, + largeThreshold, + presence, + properties, + shard, + token + ), + IdentifyProps (IdentifyProps, browser, device), + ReceivedDiscordMessage ( + EvtDispatch, + HeartBeatAck, + HeartBeatReq, + Hello, + InvalidSession, + Reconnect + ), + ResumeData (ResumeData, seq, sessionID, token), + SentDiscordMessage (HeartBeat, Identify, Resume, StatusUpdate), + Shard (..), + ShardC, + ShardFlowControl (..), + ShardMsg (..), + ShardState (ShardState, wsConn), + StatusUpdateData, + ) +import Calamity.Internal.RunIntoIO (bindSemToIO) +import Calamity.Internal.Utils ( + debug, + error, + info, + leftToMaybe, + swap, + unlessM, + untilJustFinalIO, + whenJust, + whileMFinalIO, + ) +import Calamity.Metrics.Eff ( + MetricEff, + modifyGauge, + registerGauge, + ) +import Calamity.Types.LogEff (LogEff) +import Calamity.Types.Token (Token, rawToken) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, cancel) +import Control.Concurrent.Chan.Unagi qualified as UC +import Control.Concurrent.STM (STM, atomically, retry) +import Control.Concurrent.STM.TBMQueue ( + TBMQueue, + closeTBMQueue, + newTBMQueueIO, + readTBMQueue, + tryWriteTBMQueue, + writeTBMQueue, + ) +import Control.Exception ( + Exception (fromException), + SomeException, + ) +import Control.Exception.Safe qualified as Ex +import Control.Monad (void, when) +import Control.Monad.State.Lazy (runState) +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 Data.Text qualified as T +import DiPolysemy (attr, push) +import Network.Connection qualified as NC +import Network.TLS qualified as NT +import Network.TLS.Extra qualified as NT +import Network.WebSockets ( + Connection, + ConnectionException (..), + receiveData, + sendCloseCode, + sendTextData, + ) +import Network.WebSockets qualified as NW +import Network.WebSockets.Stream qualified as NW +import Optics +import Optics.State.Operators +import Polysemy (Sem) +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) + +runWebsocket :: + (P.Members '[LogEff, P.Final IO, P.Embed IO] r) => + T.Text -> + T.Text -> + (Connection -> P.Sem r a) -> + P.Sem r (Maybe a) +runWebsocket host path ma = do + inner <- bindSemToIO ma + + -- We have to do this all ourself I think? + -- TODO: see if this isn't needed + let logExc e = debug $ "runWebsocket raised with " <> (T.pack . show $ e) + logExc' <- bindSemToIO logExc + let handler e = do + void $ logExc' e + pure Nothing + + P.embed . Ex.handleAny handler $ do + ctx <- NC.initConnectionContext + certStore <- X509.getSystemCertificateStore + let clientParams = + (NT.defaultParamsClient (T.unpack host) "443") + { NT.clientSupported = def {NT.supportedCiphers = NT.ciphersuite_default} + , NT.clientShared = + def + { NT.sharedCAStore = certStore + } + } + let tlsSettings = NC.TLSSettings clientParams + connParams = NC.ConnectionParams (T.unpack host) 443 (Just tlsSettings) Nothing + + Ex.bracket + (NC.connectTo ctx connParams) + NC.connectionClose + ( \conn -> do + stream <- + NW.makeStream + (Just <$> NC.connectionGetChunk conn) + (maybe (pure ()) (NC.connectionPut conn . LBS.toStrict)) + NW.runClientWithStream stream (T.unpack host) (T.unpack path) NW.defaultConnectionOptions [] inner + ) + +newShardState :: Shard -> ShardState +newShardState shard = ShardState shard Nothing Nothing False Nothing Nothing Nothing + +-- | Creates and launches a shard +newShard :: + (P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r) => + T.Text -> + Int -> + Int -> + Token -> + Maybe StatusUpdateData -> + Intents -> + UC.InChan CalamityEvent -> + Sem r (UC.InChan ControlMessage, Async (Maybe ())) +newShard gateway id count token presence intents evtIn = do + (cmdIn, cmdOut) <- P.embed UC.newChan + let shard = Shard id count gateway evtIn cmdOut (rawToken token) presence intents + stateVar <- P.embed . newIORef $ newShardState shard + + let runShard = P.runAtomicStateIORef stateVar shardLoop + let action = push "calamity-shard" . attr "shard-id" id $ runShard + + thread' <- P.async action + + pure (cmdIn, thread') + +sendToWs :: (ShardC r) => SentDiscordMessage -> Sem r () +sendToWs data' = do + wsConn' <- P.atomicGets wsConn + case wsConn' of + Just wsConn -> do + let encodedData = A.encode data' + debug . T.pack $ "sending " <> show data' <> " encoded to " <> show encodedData <> " to gateway" + P.embed . sendTextData wsConn $ encodedData + Nothing -> debug "tried to send to closed WS" + +tryWriteTBMQueue' :: TBMQueue a -> a -> STM Bool +tryWriteTBMQueue' q v = do + v' <- tryWriteTBMQueue q v + case v' of + Just False -> retry + Just True -> pure True + Nothing -> pure False + +restartUnless :: (P.Members '[LogEff, P.Error ShardFlowControl] r) => T.Text -> Maybe a -> P.Sem r a +restartUnless _ (Just a) = pure a +restartUnless msg Nothing = do + error msg + P.throw ShardFlowRestart + +-- | The loop a shard will run on +shardLoop :: (ShardC r) => Sem r () +shardLoop = do + activeShards <- registerGauge "active_shards" mempty + void $ modifyGauge (+ 1) activeShards + void outerloop + void $ modifyGauge (subtract 1) activeShards + debug "Shard shut down" + where + controlStream :: Shard -> TBMQueue ShardMsg -> IO () + controlStream shard outqueue = inner + where + q = shard ^. #cmdOut + inner = do + v <- UC.readChan q + r <- atomically $ tryWriteTBMQueue' outqueue (Control v) + when r inner + + handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe T.Text) a) + handleWSException e = pure $ case fromException e of + Just (CloseRequest code _) + | code `elem` [4004, 4010, 4011, 4012, 4013, 4014] -> + Left (ShutDownShard, Just . showt $ code) + e -> Left (RestartShard, Just . T.pack . show $ e) + + discordStream :: (P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r) => Connection -> TBMQueue ShardMsg -> Sem r () + discordStream ws outqueue = inner + where + inner = do + msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException + + case msg of + Left (c, reason) -> do + whenJust reason (\r -> error . T.pack $ "Shard closed with reason: " <> show r) + P.embed . atomically $ writeTBMQueue outqueue (Control c) + Right msg' -> do + -- debug [fmt|Got msg: {msg'}|] + let decoded = A.eitherDecode msg' + r <- case decoded of + Right a -> + P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) + Left e -> do + error . T.pack $ "Failed to decode " <> e <> ": " <> show msg' + pure True + when r inner + outerloop :: (ShardC r) => Sem r () + outerloop = whileMFinalIO $ do + shard :: Shard <- P.atomicGets (^. #shardS) + let host = shard ^. #gateway + let host' = fromMaybe host $ T.stripPrefix "wss://" host + info . T.pack $ "starting up shard " <> show (shardID shard) <> " of " <> show (shardCount shard) + + innerLoopVal <- runWebsocket host' "/?v=9&encoding=json" innerloop + + case innerLoopVal of + Just ShardFlowShutDown -> do + info "Shutting down shard" + pure False + Just ShardFlowRestart -> do + info "Restaring shard" + pure True + -- we restart normally when we loop + + Nothing -> do + -- won't happen unless innerloop starts using a non-deterministic effect or connecting to the ws dies + info "Restarting shard (abnormal reasons?)" + pure True + + innerloop :: (ShardC r) => Connection -> Sem r ShardFlowControl + innerloop ws = do + debug "Entering inner loop of shard" + + shard <- P.atomicGets (^. #shardS) + P.atomicModify' (#wsConn ?~ ws) + + seqNum' <- P.atomicGets (^. #seqNum) + sessionID' <- P.atomicGets (^. #sessionID) + + case (seqNum', sessionID') of + (Just n, Just s) -> do + debug $ "Resuming shard (sessionID: " <> s <> ", seq: " <> T.pack (show n) + sendToWs + ( Resume + ResumeData + { token = shard ^. #token + , sessionID = s + , seq = n + } + ) + _noActiveSession -> do + debug "Identifying shard" + sendToWs + ( Identify + IdentifyData + { token = shard ^. #token + , properties = + IdentifyProps + { browser = "Calamity: https://github.com/simmsb/calamity" + , device = "Calamity: https://github.com/simmsb/calamity" + } + , compress = False + , largeThreshold = Nothing + , shard = + Just (shard ^. #shardID, shard ^. #shardCount) + , presence = shard ^. #initialStatus + , intents = shard ^. #intents + } + ) + + result <- + P.resourceToIOFinal $ + P.bracket + (P.embed $ newTBMQueueIO 1) + (P.embed . atomically . closeTBMQueue) + ( \q -> do + debug "handling events now" + _controlThread <- P.async . P.embed $ controlStream shard q + _discordThread <- P.async $ discordStream ws q + P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do + -- only we close the queue + msg <- P.embed . atomically $ readTBMQueue q + handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg + ) + + debug "Exiting inner loop of shard" + + P.atomicModify' (#wsConn .~ Nothing) + haltHeartBeat + pure result + handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r () + handleMsg (Discord msg) = case msg of + EvtDispatch sn data' -> do + -- trace $ "Handling event: ("+||data'||+")" + P.atomicModify' (#seqNum ?~ sn) + + case data' of + Ready rdata' -> + P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID)) + _NotReady -> pure () + + shard <- P.atomicGets (^. #shardS) + P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data') + HeartBeatReq -> do + debug "Received heartbeat request" + sendHeartBeat + Reconnect -> do + debug "Being asked to restart by Discord" + P.throw ShardFlowRestart + InvalidSession resumable -> do + if resumable + then info "Received resumable invalid session" + else do + info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" + P.atomicModify' (#sessionID .~ Nothing) + P.atomicModify' (#seqNum .~ Nothing) + P.embed $ threadDelay (15 * 1000 * 1000) + P.throw ShardFlowRestart + Hello interval -> do + info . T.pack $ "Received hello, beginning to heartbeat at an interval of " <> show interval <> "ms" + startHeartBeatLoop interval + HeartBeatAck -> do + debug "Received heartbeat ack" + P.atomicModify' (#hbResponse .~ True) + handleMsg (Control msg) = case msg of + SendPresence data' -> do + debug . T.pack $ "Sending presence: (" <> show data' <> ")" + sendToWs $ StatusUpdate data' + RestartShard -> P.throw ShardFlowRestart + ShutDownShard -> P.throw ShardFlowShutDown + +startHeartBeatLoop :: (ShardC r) => Int -> Sem r () +startHeartBeatLoop interval = do + haltHeartBeat -- cancel any currently running hb thread + thread <- P.async $ heartBeatLoop interval + P.atomicModify' (#hbThread ?~ thread) + +haltHeartBeat :: (ShardC r) => Sem r () +haltHeartBeat = do + thread <- P.atomicState @ShardState . (swap .) . runState $ do + thread <- use #hbThread + #hbThread .= Nothing + pure thread + case thread of + Just t -> do + debug "Stopping heartbeat thread" + P.embed (void $ cancel t) + Nothing -> pure () + +sendHeartBeat :: (ShardC r) => Sem r () +sendHeartBeat = do + sn <- P.atomicGets (^. #seqNum) + debug . T.pack $ "Sending heartbeat (seq: " <> show sn <> ")" + sendToWs $ HeartBeat sn + P.atomicModify' (#hbResponse .~ False) + +heartBeatLoop :: (ShardC r) => Int -> Sem r () +heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do + sendHeartBeat + P.embed . threadDelay $ interval * 1000 + unlessM (P.atomicGets (^. #hbResponse)) $ do + debug "No heartbeat response, restarting shard" + wsConn <- P.note () =<< P.atomicGets (^. #wsConn) + P.embed $ sendCloseCode wsConn 4000 ("No heartbeat in time" :: T.Text) + P.throw () diff --git a/Calamity/Gateway/Types.hs b/Calamity/Gateway/Types.hs new file mode 100644 --- /dev/null +++ b/Calamity/Gateway/Types.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Types for shards +module Calamity.Gateway.Types ( + ShardC, + ShardMsg (..), + ReceivedDiscordMessage (..), + SentDiscordMessage (..), + DispatchType (..), + IdentifyData (..), + StatusUpdateData (..), + ResumeData (..), + RequestGuildMembersData (..), + IdentifyProps (..), + ControlMessage (..), + ShardFlowControl (..), + Shard (..), + ShardState (..), +) where + +import Calamity.Gateway.DispatchEvents +import Calamity.Gateway.Intents +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Metrics.Eff +import Calamity.Types.LogEff +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Presence.Activity +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice +import Calamity.Types.Snowflake +import Control.Concurrent.Async +import Control.Concurrent.Chan.Unagi +import Data.Aeson qualified as Aeson +import Data.Aeson.Optics +import Data.Aeson.Types (parseMaybe) +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 Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.AtomicState qualified as P + +type ShardC r = + ( P.Members + '[ LogEff + , P.AtomicState ShardState + , P.Embed IO + , P.Final IO + , P.Async + , MetricEff + ] + r + ) + +data ShardMsg + = Discord ReceivedDiscordMessage + | Control ControlMessage + deriving (Show) + +data ReceivedDiscordMessage + = EvtDispatch Int !DispatchData + | HeartBeatReq + | Reconnect + | InvalidSession Bool + | Hello Int + | HeartBeatAck + deriving (Show) + +instance Aeson.FromJSON ReceivedDiscordMessage where + parseJSON = Aeson.withObject "ReceivedDiscordMessage" $ \v -> do + op :: Int <- v Aeson..: "op" + case op of + 0 -> do + d <- v Aeson..: "d" + t <- v Aeson..: "t" + s <- v Aeson..: "s" + EvtDispatch s <$> parseDispatchData t d + 1 -> pure HeartBeatReq + 7 -> pure Reconnect + 9 -> InvalidSession <$> v Aeson..: "d" + 10 -> + Hello <$> do + d <- v Aeson..: "d" + d Aeson..: "heartbeat_interval" + 11 -> pure HeartBeatAck + _ -> fail $ "invalid opcode: " <> show op + +parseDispatchData :: DispatchType -> Aeson.Value -> AT.Parser DispatchData +parseDispatchData READY data' = Ready <$> Aeson.parseJSON data' +parseDispatchData RESUMED _ = pure Resumed +parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> Aeson.parseJSON data' +parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> Aeson.parseJSON data' +parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> Aeson.parseJSON data' +parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_CREATE data' = GuildCreate <$> Aeson.parseJSON data' +parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_DELETE data' = GuildDelete <$> Aeson.parseJSON data' +parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> Aeson.parseJSON data' +parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> Aeson.parseJSON data' +parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBER_ADD data' = do + guildID <- Aeson.withObject "GuildMemberAdd.guild_id" (Aeson..: "guild_id") data' + GuildMemberAdd guildID <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> Aeson.parseJSON data' +parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> Aeson.parseJSON data' +parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> Aeson.parseJSON data' +parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> Aeson.parseJSON data' +parseDispatchData INVITE_CREATE data' = InviteCreate <$> Aeson.parseJSON data' +parseDispatchData INVITE_DELETE data' = InviteDelete <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_CREATE data' = do + message <- Aeson.parseJSON data' + let member = + parseMaybe + ( Aeson.withObject "MessageCreate.member" $ \o -> do + userObject :: Aeson.Object <- o Aeson..: "author" + memberObject :: Aeson.Object <- o Aeson..: "member" + Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject) + ) + data' + + let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author" + pure $ MessageCreate message user member +parseDispatchData MESSAGE_UPDATE data' = do + message <- Aeson.parseJSON data' + let member = + parseMaybe + ( Aeson.withObject "MessageCreate.member" $ \o -> do + userObject :: Aeson.Object <- o Aeson..: "author" + memberObject :: Aeson.Object <- o Aeson..: "member" + Aeson.parseJSON $ Aeson.Object (memberObject <> "user" Aeson..= userObject) + ) + data' + let user = parseMaybe Aeson.parseJSON =<< data' ^? _Object % ix "author" + pure $ MessageUpdate message user member +parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> Aeson.parseJSON data' +parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> Aeson.parseJSON data' +parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> Aeson.parseJSON data' +parseDispatchData TYPING_START data' = TypingStart <$> Aeson.parseJSON data' +parseDispatchData USER_UPDATE data' = UserUpdate <$> Aeson.parseJSON data' +parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> Aeson.parseJSON data' +parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> Aeson.parseJSON data' +parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> Aeson.parseJSON data' +parseDispatchData INTERACTION_CREATE data' = InteractionCreate <$> Aeson.parseJSON data' +parseDispatchData e _ = pure . UNHANDLED . T.pack . show $ e + +data SentDiscordMessage + = StatusUpdate StatusUpdateData + | Identify IdentifyData + | HeartBeat (Maybe Int) + | VoiceStatusUpdate VoiceState + | Resume ResumeData + | RequestGuildMembers RequestGuildMembersData + deriving (Show) + +instance Aeson.ToJSON SentDiscordMessage where + toJSON (HeartBeat data') = Aeson.object ["op" Aeson..= (1 :: Int), "d" Aeson..= data'] + toJSON (Identify data') = Aeson.object ["op" Aeson..= (2 :: Int), "d" Aeson..= data'] + toJSON (StatusUpdate data') = Aeson.object ["op" Aeson..= (3 :: Int), "d" Aeson..= data'] + toJSON (VoiceStatusUpdate data') = Aeson.object ["op" Aeson..= (4 :: Int), "d" Aeson..= data'] + toJSON (Resume data') = Aeson.object ["op" Aeson..= (6 :: Int), "d" Aeson..= data'] + toJSON (RequestGuildMembers data') = Aeson.object ["op" Aeson..= (8 :: Int), "d" Aeson..= data'] + + toEncoding (HeartBeat data') = Aeson.pairs ("op" Aeson..= (1 :: Int) <> "d" Aeson..= data') + toEncoding (Identify data') = Aeson.pairs ("op" Aeson..= (2 :: Int) <> "d" Aeson..= data') + toEncoding (StatusUpdate data') = Aeson.pairs ("op" Aeson..= (3 :: Int) <> "d" Aeson..= data') + toEncoding (VoiceStatusUpdate data') = Aeson.pairs ("op" Aeson..= (4 :: Int) <> "d" Aeson..= data') + toEncoding (Resume data') = Aeson.pairs ("op" Aeson..= (6 :: Int) <> "d" Aeson..= data') + toEncoding (RequestGuildMembers data') = Aeson.pairs ("op" Aeson..= (8 :: Int) <> "d" Aeson..= data') + +-- Thanks sbrg: +-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs +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 + | GUILD_MEMBER_UPDATE + | GUILD_MEMBERS_CHUNK + | 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 + | MESSAGE_UPDATE + | MESSAGE_DELETE + | MESSAGE_DELETE_BULK + | 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 + deriving (Show, Eq, Enum, Generic) + deriving (Aeson.ToJSON, Aeson.FromJSON) + +data IdentifyData = IdentifyData + { token :: Text + , properties :: IdentifyProps + , compress :: Bool + , largeThreshold :: Maybe Int + , shard :: Maybe (Int, Int) + , presence :: Maybe StatusUpdateData + , intents :: Intents + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON IdentifyData + +instance CalamityToJSON' IdentifyData where + toPairs IdentifyData {..} = + [ "token" .= token + , "properties" .= properties + , "compress" .= compress + , "large_threshold" .?= largeThreshold + , "shard" .?= shard + , "presence" .?= presence + , "intents" .= intents + ] + +data StatusUpdateData = StatusUpdateData + { since :: Maybe Integer + , activities :: [Activity] + , status :: StatusType + , afk :: Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON StatusUpdateData + +instance CalamityToJSON' StatusUpdateData where + toPairs StatusUpdateData {..} = + [ "since" .= since + , "activities" .= activities + , "status" .= status + , "afk" .= afk + ] + +data ResumeData = ResumeData + { token :: Text + , sessionID :: Text + , seq :: Int + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ResumeData + +instance CalamityToJSON' ResumeData where + toPairs ResumeData {..} = + [ "token" .= token + , "session_id" .= sessionID + , "seq" .= seq + ] + +data RequestGuildMembersData = RequestGuildMembersData + { guildID :: Snowflake Guild + , query :: Maybe Text + , limit :: Int + , presences :: Maybe Bool + , userIDs :: Maybe [Snowflake User] + , nonce :: Maybe Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON RequestGuildMembersData + +instance CalamityToJSON' RequestGuildMembersData where + toPairs RequestGuildMembersData {..} = + [ "guild_id" .= guildID + , "query" .?= query + , "limit" .= limit + , "presences" .?= presences + , "user_ids" .?= userIDs + , "nonce" .?= nonce + ] + +data IdentifyProps = IdentifyProps + { browser :: Text + , device :: Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON IdentifyProps + +instance CalamityToJSON' IdentifyProps where + toPairs IdentifyProps {..} = ["$browser" .= browser, "$device" .= device] + +data ControlMessage + = RestartShard + | ShutDownShard + | SendPresence StatusUpdateData + deriving (Show) + +data ShardFlowControl + = ShardFlowRestart + | ShardFlowShutDown + deriving (Show) + +data Shard = Shard + { shardID :: Int + , shardCount :: Int + , gateway :: Text + , evtIn :: InChan CalamityEvent + , cmdOut :: OutChan ControlMessage + , token :: Text + , initialStatus :: Maybe StatusUpdateData + , intents :: Intents + } + +data ShardState = ShardState + { shardS :: Shard + , seqNum :: Maybe Int + , hbThread :: Maybe (Async (Maybe ())) + , hbResponse :: Bool + , wsHost :: Maybe Text + , sessionID :: Maybe Text + , wsConn :: Maybe Connection + } + +$(makeFieldLabelsNoPrefix ''Shard) +$(makeFieldLabelsNoPrefix ''ShardState) diff --git a/Calamity/HTTP.hs b/Calamity/HTTP.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP.hs @@ -0,0 +1,62 @@ +-- | Combined http request stuff +module Calamity.HTTP ( + invoke, + module Calamity.HTTP.AuditLog, + module Calamity.HTTP.Channel, + module Calamity.HTTP.Emoji, + module Calamity.HTTP.Guild, + module Calamity.HTTP.Invite, + module Calamity.HTTP.Interaction, + module Calamity.HTTP.MiscRoutes, + module Calamity.HTTP.User, + module Calamity.HTTP.Reason, + module Calamity.HTTP.Webhook, + module Calamity.HTTP.Internal.Types, + RatelimitEff (..), + TokenEff (..), + + -- * HTTP + -- $httpDocs +) where + +import Calamity.HTTP.AuditLog +import Calamity.HTTP.Channel +import Calamity.HTTP.Emoji +import Calamity.HTTP.Guild +import Calamity.HTTP.Interaction +import Calamity.HTTP.Internal.Ratelimit (RatelimitEff (..)) +import Calamity.HTTP.Internal.Request (invoke) +import Calamity.HTTP.Internal.Types (RestError) +import Calamity.HTTP.Invite +import Calamity.HTTP.MiscRoutes +import Calamity.HTTP.Reason +import Calamity.HTTP.User +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' + @ +-} diff --git a/Calamity/HTTP/AuditLog.hs b/Calamity/HTTP/AuditLog.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/AuditLog.hs @@ -0,0 +1,43 @@ +-- | Audit Log endpoints +module Calamity.HTTP.AuditLog ( + AuditLogRequest (..), + GetAuditLogOptions (..), +) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Default.Class +import Data.Function ((&)) + +data GetAuditLogOptions = GetAuditLogOptions + { userID :: Maybe (Snowflake User) + , actionType :: Maybe AuditLogAction + , before :: Maybe (Snowflake AuditLogEntry) + , limit :: Maybe Integer + } + deriving (Show) + +instance Default GetAuditLogOptions where + def = GetAuditLogOptions Nothing Nothing Nothing Nothing + +data AuditLogRequest a where + GetAuditLog :: (HasID Guild g) => g -> GetAuditLogOptions -> AuditLogRequest AuditLog + +instance Request (AuditLogRequest a) where + type Result (AuditLogRequest a) = a + + route (GetAuditLog (getID @Guild -> gid) _) = + mkRouteBuilder // S "guilds" // ID @Guild // S "audit-logs" + & giveID gid + & buildRoute + + action (GetAuditLog _ GetAuditLogOptions {userID, actionType, before, limit}) = + getWithP + ( "user_id" =:? (fromSnowflake <$> userID) + <> "action_type" =:? (fromEnum <$> actionType) + <> "before" =:? (fromSnowflake <$> before) + <> "limit" =:? limit + ) diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Channel.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Channel endpoints +module Calamity.HTTP.Channel ( + ChannelRequest (..), + CreateMessageAttachment (..), + CreateMessageOptions (..), + EditMessageData (..), + editMessageContent, + editMessageEmbeds, + editMessageFlags, + editMessageAllowedMentions, + editMessageComponents, + ChannelUpdate (..), + AllowedMentionType (..), + AllowedMentions (..), + ChannelMessagesFilter (..), + ChannelMessagesLimit (..), + GetReactionsOptions (..), + CreateChannelInviteOptions (..), + GroupDMAddRecipientOptions (..), +) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Emoji (RawEmoji (..)) +import Calamity.Types.Model.Guild.Invite (Invite) +import Calamity.Types.Model.Guild.Overwrite (Overwrite) +import Calamity.Types.Model.Guild.Role (Role) +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as K +import Data.Default.Class +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word +import Network.HTTP.Client (RequestBody) +import Network.HTTP.Client.MultipartFormData +import Network.HTTP.Req +import Network.Mime +import Optics +import TextShow + +data CreateMessageAttachment = CreateMessageAttachment + { filename :: Text + , description :: Maybe Text + , content :: RequestBody + } + +instance Show CreateMessageAttachment where + show (CreateMessageAttachment filename description _) = + mconcat + [ "CreateMessageAttachment {filename = " + , show filename + , ", description = " + , show description + , ", content = }" + ] + +data CreateMessageOptions = CreateMessageOptions + { content :: Maybe Text + , nonce :: Maybe Text + , tts :: Maybe Bool + , attachments :: Maybe [CreateMessageAttachment] + , embeds :: Maybe [Embed] + , allowedMentions :: Maybe AllowedMentions + , messageReference :: Maybe MessageReference + , components :: Maybe [Component] + } + deriving (Show) + +instance Default CreateMessageOptions where + def = CreateMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data CreateMessageAttachmentJson = CreateMessageAttachmentJson + { id :: Int + , filename :: Text + , description :: Maybe Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson + +instance CalamityToJSON' CreateMessageAttachmentJson where + toPairs CreateMessageAttachmentJson {..} = + [ "filename" .= filename + , "description" .?= description + , "id" .= id + ] + +data CreateMessageJson = CreateMessageJson + { content :: Maybe Text + , nonce :: Maybe Text + , tts :: Maybe Bool + , embeds :: Maybe [Embed] + , allowedMentions :: Maybe AllowedMentions + , messageReference :: Maybe MessageReference + , components :: Maybe [Component] + , attachments :: Maybe [CreateMessageAttachmentJson] + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageJson + +instance CalamityToJSON' CreateMessageJson where + toPairs CreateMessageJson {..} = + [ "content" .?= content + , "nonce" .?= nonce + , "tts" .?= tts + , "embeds" .?= embeds + , "allowed_mentions" .?= allowedMentions + , "message_reference" .?= messageReference + , "components" .?= components + , "attachments" .?= attachments + ] + +data AllowedMentionType + = AllowedMentionRoles + | AllowedMentionUsers + | AllowedMentionEveryone + deriving (Show) + +instance Aeson.ToJSON AllowedMentionType where + toJSON AllowedMentionRoles = Aeson.String "roles" + toJSON AllowedMentionUsers = Aeson.String "users" + toJSON AllowedMentionEveryone = Aeson.String "everyone" + +data AllowedMentions = AllowedMentions + { parse :: [AllowedMentionType] + , roles :: [Snowflake Role] + , users :: [Snowflake User] + , repliedUser :: Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON AllowedMentions + +instance CalamityToJSON' AllowedMentions where + toPairs AllowedMentions {..} = + [ "parse" .= parse + , "roles" .= roles + , "users" .= users + , "replied_user" .= repliedUser + ] + +instance Default AllowedMentions where + def = AllowedMentions def def def False + +instance Semigroup AllowedMentions where + AllowedMentions p0 r0 u0 ru0 <> AllowedMentions p1 r1 u1 ru1 = + AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1) (ru0 || ru1) + +instance Monoid AllowedMentions where + mempty = def + +{- | Parameters to the Edit Message endpoint. + + Use the provided methods (@editMessageX@) to create a value with the + field set, use the Semigroup instance to union the values. + + ==== Examples + + >>> encode $ editMessageContent (Just "test") <> editMessageFlags Nothing + "{\"nick\":\"test\",\"deaf\":null}" +-} +newtype EditMessageData = EditMessageData Aeson.Object + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Semigroup, Monoid) + +editMessageContent :: Maybe Text -> EditMessageData +editMessageContent v = EditMessageData $ K.fromList [("content", Aeson.toJSON v)] + +editMessageEmbeds :: [Embed] -> EditMessageData +editMessageEmbeds v = EditMessageData $ K.fromList [("embeds", Aeson.toJSON v)] + +editMessageFlags :: Maybe Word64 -> EditMessageData +editMessageFlags v = EditMessageData $ K.fromList [("flags", Aeson.toJSON v)] + +editMessageAllowedMentions :: Maybe AllowedMentions -> EditMessageData +editMessageAllowedMentions v = EditMessageData $ K.fromList [("allowed_mentions", Aeson.toJSON v)] + +editMessageComponents :: [Component] -> EditMessageData +editMessageComponents v = EditMessageData $ K.fromList [("components", Aeson.toJSON v)] + +data ChannelUpdate = ChannelUpdate + { name :: Maybe Text + , position :: Maybe Int + , topic :: Maybe Text + , nsfw :: Maybe Bool + , rateLimitPerUser :: Maybe Int + , bitrate :: Maybe Int + , userLimit :: Maybe Int + , permissionOverwrites :: Maybe [Overwrite] + , parentID :: Maybe (Snowflake Channel) + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelUpdate + +instance Default ChannelUpdate where + def = ChannelUpdate Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance CalamityToJSON' ChannelUpdate where + toPairs ChannelUpdate {..} = + [ "name" .?= name + , "position" .?= position + , "topic" .?= topic + , "nsfw" .?= nsfw + , "rate_limit_per_user" .?= rateLimitPerUser + , "bitrate" .?= bitrate + , "user_limit" .?= userLimit + , "permission_overwrites" .?= permissionOverwrites + , "parent_id" .?= parentID + ] + +data ChannelMessagesFilter + = ChannelMessagesAround + { around :: Snowflake Message + } + | ChannelMessagesBefore + { before :: Snowflake Message + } + | ChannelMessagesAfter + { after :: Snowflake Message + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelMessagesFilter + +instance CalamityToJSON' ChannelMessagesFilter where + toPairs ChannelMessagesAround {around} = ["around" .= around] + toPairs ChannelMessagesBefore {before} = ["before" .= before] + toPairs ChannelMessagesAfter {after} = ["after" .= after] + +newtype ChannelMessagesLimit = ChannelMessagesLimit + { limit :: Integer + } + deriving stock (Show) + +data GetReactionsOptions = GetReactionsOptions + { before :: Maybe (Snowflake User) + , after :: Maybe (Snowflake User) + , limit :: Maybe Integer + } + deriving (Show) + +instance Default GetReactionsOptions where + def = GetReactionsOptions Nothing Nothing Nothing + +data CreateChannelInviteOptions = CreateChannelInviteOptions + { maxAge :: Maybe Int + , maxUses :: Maybe Int + , temporary :: Maybe Bool + , unique :: Maybe Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateChannelInviteOptions + +instance Default CreateChannelInviteOptions where + def = CreateChannelInviteOptions Nothing Nothing Nothing Nothing + +instance CalamityToJSON' CreateChannelInviteOptions where + toPairs CreateChannelInviteOptions {..} = + [ "max_age" .?= maxAge + , "max_uses" .?= maxUses + , "temporary" .?= temporary + , "unique" .?= unique + ] + +data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions + { accessToken :: Text + , nick :: Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON GroupDMAddRecipientOptions + +instance CalamityToJSON' GroupDMAddRecipientOptions where + toPairs GroupDMAddRecipientOptions {..} = + [ "access_token" .= accessToken + , "nick" .= nick + ] + +$(makeFieldLabelsNoPrefix ''CreateMessageAttachment) +$(makeFieldLabelsNoPrefix ''CreateMessageOptions) +$(makeFieldLabelsNoPrefix ''CreateMessageAttachmentJson) +$(makeFieldLabelsNoPrefix ''AllowedMentions) +$(makeFieldLabelsNoPrefix ''ChannelUpdate) +$(makeFieldLabelsNoPrefix ''ChannelMessagesFilter) +$(makeFieldLabelsNoPrefix ''ChannelMessagesLimit) +$(makeFieldLabelsNoPrefix ''GetReactionsOptions) +$(makeFieldLabelsNoPrefix ''CreateChannelInviteOptions) +$(makeFieldLabelsNoPrefix ''GroupDMAddRecipientOptions) + +data ChannelRequest a where + CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message + CrosspostMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message + GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message + EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> EditMessageData -> ChannelRequest Message + DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + BulkDeleteMessages :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest () + GetChannel :: (HasID Channel c) => c -> ChannelRequest Channel + ModifyChannel :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel + DeleteChannel :: (HasID Channel c) => c -> ChannelRequest () + GetChannelMessages :: (HasID Channel c) => c -> Maybe ChannelMessagesFilter -> Maybe ChannelMessagesLimit -> ChannelRequest [Message] + CreateReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () + DeleteOwnReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () + DeleteUserReaction :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest () + GetReactions :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User] + DeleteAllReactions :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + GetChannelInvites :: (HasID Channel c) => c -> ChannelRequest [Invite] + CreateChannelInvite :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite + EditChannelPermissions :: (HasID Channel c) => c -> Overwrite -> ChannelRequest () + DeleteChannelPermission :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest () + TriggerTyping :: (HasID Channel c) => c -> ChannelRequest () + GetPinnedMessages :: (HasID Channel c) => c -> ChannelRequest [Message] + AddPinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + DeletePinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () + GroupDMAddRecipient :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest () + GroupDMRemoveRecipient :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest () + +baseRoute :: Snowflake Channel -> RouteBuilder _ +baseRoute id = + mkRouteBuilder + // S "channels" + // ID @Channel + & giveID id + +renderEmoji :: RawEmoji -> Text +renderEmoji (UnicodeEmoji e) = e +renderEmoji (CustomEmoji e) = e ^. #name <> ":" <> showt (e ^. #id) + +instance Request (ChannelRequest a) where + type Result (ChannelRequest a) = a + + route (CreateMessage (getID -> id) _) = + baseRoute id + // S "messages" + & buildRoute + route (CrosspostMessage (getID -> id) (getID @Message -> mid)) = + baseRoute id + // S "messages" + // ID @Message + & giveID mid + & buildRoute + route (GetChannel (getID -> id)) = + baseRoute id + & buildRoute + route (ModifyChannel (getID -> id) _) = + baseRoute id + & buildRoute + route (DeleteChannel (getID -> id)) = + baseRoute id + & buildRoute + route (GetChannelMessages (getID -> id) _ _) = + baseRoute id + // S "messages" + & buildRoute + route (GetMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid + // S "messages" + // ID @Message + & giveID mid + & buildRoute + route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + // S "@me" + & giveID mid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute + route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + // S "@me" + & giveID mid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute + route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + // ID @User + & giveID mid + & giveID uid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute + route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + // PS @"emoji" + & giveID mid + & giveParam @"emoji" (renderEmoji emoji) + & buildRoute + route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = + baseRoute cid + // S "messages" + // ID @Message + // S "reactions" + & giveID mid + & buildRoute + route (EditMessage (getID -> cid) (getID @Message -> mid) _) = + baseRoute cid + // S "messages" + // ID @Message + & giveID mid + & buildRoute + route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid + // S "messages" + // ID @Message + & giveID mid + & buildRoute + route (BulkDeleteMessages (getID -> cid) _) = + baseRoute cid + // S "messages" + // S "bulk-delete" + & buildRoute + route (GetChannelInvites (getID -> cid)) = + baseRoute cid + // S "invites" + & buildRoute + route (CreateChannelInvite (getID -> cid) _) = + baseRoute cid + // S "invites" + & buildRoute + route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) = + baseRoute cid + // S "permissions" + // ID @Overwrite + & giveID oid + & buildRoute + route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = + baseRoute cid + // S "permissions" + // ID @Overwrite + & giveID oid + & buildRoute + route (TriggerTyping (getID -> cid)) = + baseRoute cid + // S "typing" + & buildRoute + route (GetPinnedMessages (getID -> cid)) = + baseRoute cid + // S "pins" + & buildRoute + route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid + // S "pins" + // ID @Message + & giveID mid + & buildRoute + route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = + baseRoute cid + // S "pins" + // ID @Message + & giveID mid + & buildRoute + route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = + baseRoute cid + // S "recipients" + // ID @User + & giveID uid + & buildRoute + route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = + baseRoute cid + // S "recipients" + // ID @User + & giveID uid + & buildRoute + action (CreateMessage _ cm) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] + attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments + jsonBody = + CreateMessageJson + { content = cm ^. #content + , nonce = cm ^. #nonce + , tts = cm ^. #tts + , embeds = cm ^. #embeds + , allowedMentions = cm ^. #allowedMentions + , messageReference = cm ^. #messageReference + , components = cm ^. #components + , attachments = attachments + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) + postWith' body u o + action (CrosspostMessage _ _) = postEmpty + action (GetChannel _) = getWith + action (ModifyChannel _ p) = patchWith' (ReqBodyJson p) + action (DeleteChannel _) = deleteWith + action (GetChannelMessages _ (Just (ChannelMessagesAround (fromSnowflake -> a))) l) = + getWithP ("around" =: a <> "limit" =:? (l ^? _Just % #limit)) + action (GetChannelMessages _ (Just (ChannelMessagesBefore (fromSnowflake -> a))) l) = + getWithP ("before" =: a <> "limit" =:? (l ^? _Just % #limit)) + action (GetChannelMessages _ (Just (ChannelMessagesAfter (fromSnowflake -> a))) l) = + getWithP ("after" =: a <> "limit" =:? (l ^? _Just % #limit)) + action (GetChannelMessages _ Nothing l) = getWithP ("limit" =:? (l ^? _Just % #limit)) + action (GetMessage _ _) = getWith + action CreateReaction {} = putEmpty + action DeleteOwnReaction {} = deleteWith + action DeleteUserReaction {} = deleteWith + action (GetReactions _ _ _ GetReactionsOptions {before, after, limit}) = + getWithP + ( "before" =:? (fromSnowflake <$> before) + <> "after" =:? (fromSnowflake <$> after) + <> "limit" =:? limit + ) + action (DeleteAllReactions _ _) = deleteWith + action (EditMessage _ _ o) = patchWith' (ReqBodyJson o) + action (DeleteMessage _ _) = deleteWith + action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (ReqBodyJson $ Aeson.object ["messages" Aeson..= ids]) + action (GetChannelInvites _) = getWith + action (CreateChannelInvite _ o) = postWith' (ReqBodyJson o) + action (EditChannelPermissions _ o) = putWith' (ReqBodyJson o) + action (DeleteChannelPermission _ _) = deleteWith + action (TriggerTyping _) = postEmpty + action (GetPinnedMessages _) = getWith + action (AddPinnedMessage _ _) = putEmpty + action (DeletePinnedMessage _ _) = deleteWith + action (GroupDMAddRecipient _ _ o) = putWith' (ReqBodyJson o) + action (GroupDMRemoveRecipient _ _) = deleteWith diff --git a/Calamity/HTTP/Emoji.hs b/Calamity/HTTP/Emoji.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Emoji.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Emoji endpoints +module Calamity.HTTP.Emoji ( + EmojiRequest (..), + CreateGuildEmojiOptions (..), + ModifyGuildEmojiOptions (..), +) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake +import Data.Aeson qualified as Aeson +import Data.Function +import Data.Text (Text) +import Network.HTTP.Req +import Optics.TH + +data CreateGuildEmojiOptions = CreateGuildEmojiOptions + { name :: Text + , image :: Text + , roles :: [Snowflake Role] + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateGuildEmojiOptions + +instance CalamityToJSON' CreateGuildEmojiOptions where + toPairs CreateGuildEmojiOptions {..} = + [ "name" .= name + , "image" .= image + , "roles" .= roles + ] + +data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions + { name :: Text + , roles :: [Snowflake Role] + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildEmojiOptions + +instance CalamityToJSON' ModifyGuildEmojiOptions where + toPairs ModifyGuildEmojiOptions {..} = + [ "name" .= name + , "roles" .= roles + ] + +data EmojiRequest a where + ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji] + GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji + CreateGuildEmoji :: (HasID Guild g) => g -> CreateGuildEmojiOptions -> EmojiRequest Emoji + ModifyGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> ModifyGuildEmojiOptions -> EmojiRequest Emoji + DeleteGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest () + +baseRoute :: Snowflake Guild -> RouteBuilder _ +baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild // S "emojis" & giveID id + +instance Request (EmojiRequest a) where + type Result (EmojiRequest a) = a + + route (ListGuildEmojis (getID -> gid)) = baseRoute gid & buildRoute + route (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = + baseRoute gid // ID @Emoji + & giveID eid + & buildRoute + route (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute + route (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = + baseRoute gid // ID @Emoji + & giveID eid + & buildRoute + route (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = + baseRoute gid // ID @Emoji + & giveID eid + & buildRoute + + action (ListGuildEmojis _) = getWith + action (GetGuildEmoji _ _) = getWith + action (CreateGuildEmoji _ o) = postWith' (ReqBodyJson o) + action (ModifyGuildEmoji _ _ o) = patchWith' (ReqBodyJson o) + action (DeleteGuildEmoji _ _) = deleteWith + +$(makeFieldLabelsNoPrefix ''CreateGuildEmojiOptions) +$(makeFieldLabelsNoPrefix ''ModifyGuildEmojiOptions) diff --git a/Calamity/HTTP/Guild.hs b/Calamity/HTTP/Guild.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Guild.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Guild endpoints +module Calamity.HTTP.Guild ( + GuildRequest (..), + CreateGuildData (..), + ModifyGuildData (..), + ChannelCreateData (..), + ChannelPosition (..), + ListMembersOptions (..), + AddGuildMemberData (..), + ModifyGuildMemberData, + modifyGuildMemberNick, + modifyGuildMemberRoles, + modifyGuildMemberMute, + modifyGuildMemberDeaf, + modifyGuildMemberChannelID, + CreateGuildBanData (..), + ModifyGuildRoleData, + modifyGuildRoleName, + modifyGuildRolePermissions, + modifyGuildRoleColour, + modifyGuildRoleHoist, + modifyGuildRoleMentionable, + ModifyGuildRolePositionsData (..), +) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.IntColour +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice +import Calamity.Types.Snowflake +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as K +import Data.Colour (Colour) +import Data.Default.Class +import Data.Text (Text) +import Network.HTTP.Req +import Optics + +data CreateGuildData = CreateGuildData + { name :: Text + , region :: Text + , icon :: Text + , verificationLevel :: Integer -- TODO: enums for these + , defaultMessageNotifications :: Integer + , explicitContentFilter :: Integer + , roles :: [Role] + , channels :: [Partial Channel] + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateGuildData + +instance CalamityToJSON' CreateGuildData where + toPairs CreateGuildData {..} = + [ "name" .= name + , "region" .= region + , "icon" .= icon + , "verification_level" .= verificationLevel + , "default_message_notifications" .= defaultMessageNotifications + , "explicit_content_filter" .= explicitContentFilter + , "roles" .= roles + , "channels" .= channels + ] + +data ModifyGuildData = ModifyGuildData + { name :: Maybe Text + , region :: Maybe Text + , icon :: Maybe Text + , verificationLevel :: Maybe Integer -- TODO: enums for these + , defaultMessageNotifications :: Maybe Integer + , explicitContentFilter :: Maybe Integer + , afkChannelID :: Maybe (Snowflake GuildChannel) + , afkTimeout :: Maybe Integer + , ownerID :: Maybe (Snowflake User) + , splash :: Maybe Text + , banner :: Maybe Text + , systemChannelID :: Maybe (Snowflake GuildChannel) + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildData + +instance Default ModifyGuildData where + def = + ModifyGuildData + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +-- TODO: Make this work properly, a la modifyguildmember +instance CalamityToJSON' ModifyGuildData where + toPairs ModifyGuildData {..} = + [ "name" .?= name + , "region" .?= region + , "icon" .?= icon + , "verification_level" .?= verificationLevel + , "default_message_notifications" .?= defaultMessageNotifications + , "explicit_content_filter" .?= explicitContentFilter + , "afk_timeout" .?= afkTimeout + , "owner_id" .?= ownerID + , "splash" .?= splash + , "banner" .?= banner + , "system_channel_id" .?= systemChannelID + ] + +data ChannelCreateData = ChannelCreateData + { name :: Text + , type_ :: Maybe ChannelType + , topic :: Maybe Text + , bitrate :: Maybe Integer + , userLimit :: Maybe Integer + , rateLimitPerUser :: Maybe Integer + , position :: Maybe Integer + , permissionOverwrites :: Maybe [Overwrite] + , parentID :: Maybe (Snowflake Category) + , nsfw :: Maybe Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelCreateData + +instance CalamityToJSON' ChannelCreateData where + toPairs ChannelCreateData {..} = + [ "name" .= name + , "type" .?= type_ + , "topic" .?= topic + , "bitrate" .?= bitrate + , "user_limit" .?= userLimit + , "rate_limit_per_user" .?= rateLimitPerUser + , "position" .?= position + , "permission_overwrites" .?= permissionOverwrites + , "parent_id" .?= parentID + , "nsfw" .?= nsfw + ] + +data ChannelPosition = ChannelPosition + { id :: Snowflake GuildChannel + , position :: Maybe Integer + , lockPermissions :: Maybe Bool + , parentID :: Snowflake GuildChannel + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ChannelPosition + +instance CalamityToJSON' ChannelPosition where + toPairs ChannelPosition {..} = + [ "id" .= id + , "position" .= position + , "lock_permissions" .= lockPermissions + , "parent_id" .= parentID + ] + +data ListMembersOptions = ListMembersOptions + { limit :: Maybe Integer + , after :: Maybe (Snowflake User) + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ListMembersOptions + +instance Default ListMembersOptions where + def = ListMembersOptions Nothing Nothing + +instance CalamityToJSON' ListMembersOptions where + toPairs ListMembersOptions {..} = + [ "limit" .?= limit + , "after" .?= after + ] + +data SearchMembersOptions = SearchMembersOptions + { limit :: Maybe Integer + , query :: Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON SearchMembersOptions + +instance CalamityToJSON' SearchMembersOptions where + toPairs SearchMembersOptions {..} = + [ "limit" .?= limit + , "query" .= query + ] + +data AddGuildMemberData = AddGuildMemberData + { accessToken :: Text + , nick :: Maybe Text + , roles :: Maybe [Snowflake Role] + , mute :: Maybe Bool + , deaf :: Maybe Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON AddGuildMemberData + +instance CalamityToJSON' AddGuildMemberData where + toPairs AddGuildMemberData {..} = + [ "access_token" .= accessToken + , "nick" .?= nick + , "roles" .?= roles + , "mute" .?= mute + , "deaf" .?= deaf + ] + +{- | Parameters to the Modify Guild Member endpoint. + + Use the provided methods (@modifyGuildMemberX@) to create a value with the + field set, use the Semigroup instance to combine modifications. + + ==== Examples + + >>> encode $ modifyGuildMemberNick (Just "test") <> modifyGuildMemberDeaf Nothing + "{\"nick\":\"test\",\"deaf\":null}" +-} +newtype ModifyGuildMemberData = ModifyGuildMemberData Aeson.Object + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Semigroup, Monoid) + +modifyGuildMemberNick :: Maybe Text -> ModifyGuildMemberData +modifyGuildMemberNick v = ModifyGuildMemberData $ K.fromList [("nick", Aeson.toJSON v)] + +modifyGuildMemberRoles :: Maybe [Snowflake Role] -> ModifyGuildMemberData +modifyGuildMemberRoles v = ModifyGuildMemberData $ K.fromList [("roles", Aeson.toJSON v)] + +modifyGuildMemberMute :: Maybe Bool -> ModifyGuildMemberData +modifyGuildMemberMute v = ModifyGuildMemberData $ K.fromList [("mute", Aeson.toJSON v)] + +modifyGuildMemberDeaf :: Maybe Bool -> ModifyGuildMemberData +modifyGuildMemberDeaf v = ModifyGuildMemberData $ K.fromList [("deaf", Aeson.toJSON v)] + +modifyGuildMemberChannelID :: Maybe (Snowflake VoiceChannel) -> ModifyGuildMemberData +modifyGuildMemberChannelID v = ModifyGuildMemberData $ K.fromList [("channel_id", Aeson.toJSON v)] + +data GetGuildBansOptions = GetGuildBansOptions + { limit :: Maybe Int + , before :: Maybe Int + , after :: Maybe Int + } + deriving (Show) + +instance Default GetGuildBansOptions where + def = GetGuildBansOptions Nothing Nothing Nothing + +data CreateGuildBanData = CreateGuildBanData + { deleteMessageDays :: Maybe Integer + , reason :: Maybe Text + } + deriving (Show) + +instance Default CreateGuildBanData where + def = CreateGuildBanData Nothing Nothing + +{- | Parameters to the Modify Guild Role endpoint. + + Use the provided methods (@modifyGuildRoleX@) to create a value with the + field set, use the Semigroup instance to combine parameters. + + ==== Examples + + >>> encode $ modifyGuildRoleName (Just "test") <> modifyGuildRolePermissions Nothing + "{\"name\":\"test\",\"permissions\":null}" +-} +newtype ModifyGuildRoleData = ModifyGuildRoleData Aeson.Object + deriving stock (Show) + deriving newtype (Aeson.ToJSON, Semigroup, Monoid) + +modifyGuildRoleName :: Maybe Text -> ModifyGuildRoleData +modifyGuildRoleName v = ModifyGuildRoleData $ K.fromList [("name", Aeson.toJSON v)] + +modifyGuildRolePermissions :: Maybe Permissions -> ModifyGuildRoleData +modifyGuildRolePermissions v = ModifyGuildRoleData $ K.fromList [("permissions", Aeson.toJSON v)] + +modifyGuildRoleColour :: Maybe (Colour Double) -> ModifyGuildRoleData +modifyGuildRoleColour v = ModifyGuildRoleData $ K.fromList [("colour", Aeson.toJSON (IntColour <$> v))] + +modifyGuildRoleHoist :: Maybe Bool -> ModifyGuildRoleData +modifyGuildRoleHoist v = ModifyGuildRoleData $ K.fromList [("hoist", Aeson.toJSON v)] + +modifyGuildRoleMentionable :: Maybe Bool -> ModifyGuildRoleData +modifyGuildRoleMentionable v = ModifyGuildRoleData $ K.fromList [("mentionable", Aeson.toJSON v)] + +data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData + { id :: Snowflake Role + , position :: Maybe Integer + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyGuildRolePositionsData + +instance CalamityToJSON' ModifyGuildRolePositionsData where + toPairs ModifyGuildRolePositionsData {..} = + [ "id" .= id + , "postition" .?= position + ] + +data GuildRequest a where + CreateGuild :: CreateGuildData -> GuildRequest Guild + GetGuild :: (HasID Guild g) => g -> GuildRequest Guild + ModifyGuild :: (HasID Guild g) => g -> ModifyGuildData -> GuildRequest Guild + DeleteGuild :: (HasID Guild g) => g -> GuildRequest () + GetGuildChannels :: (HasID Guild g) => g -> GuildRequest [Channel] + CreateGuildChannel :: (HasID Guild g) => g -> ChannelCreateData -> GuildRequest Channel + ModifyGuildChannelPositions :: (HasID Guild g) => g -> [ChannelPosition] -> GuildRequest () + GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member + ListGuildMembers :: (HasID Guild g) => g -> ListMembersOptions -> GuildRequest [Member] + SearchGuildMembers :: (HasID Guild g) => g -> SearchMembersOptions -> GuildRequest [Member] + AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member) + ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest () + ModifyCurrentUserNick :: (HasID Guild g) => g -> Maybe Text -> GuildRequest () + AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () + RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () + RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () + GetGuildBans :: (HasID Guild g) => g -> GetGuildBansOptions -> GuildRequest [BanData] + GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData + CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest () + RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () + GetGuildRoles :: (HasID Guild g) => g -> GuildRequest [Role] + CreateGuildRole :: (HasID Guild g) => g -> ModifyGuildRoleData -> GuildRequest Role + ModifyGuildRolePositions :: (HasID Guild g) => g -> ModifyGuildRolePositionsData -> GuildRequest [Role] + ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role + DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest () + GetGuildPruneCount :: (HasID Guild g) => g -> Integer -> GuildRequest Integer + BeginGuildPrune :: (HasID Guild g) => g -> Integer -> Bool -> GuildRequest (Maybe Integer) + GetGuildVoiceRegions :: (HasID Guild g) => g -> GuildRequest [VoiceRegion] + GetGuildInvites :: (HasID Guild g) => g -> GuildRequest [Invite] + +baseRoute :: Snowflake Guild -> RouteBuilder _ +baseRoute id = + mkRouteBuilder + // S "guilds" + // ID @Guild + & giveID id + +instance Request (GuildRequest a) where + type Result (GuildRequest a) = a + + route (CreateGuild _) = + mkRouteBuilder + // S "guilds" + & buildRoute + route (GetGuild (getID -> gid)) = + baseRoute gid + & buildRoute + route (ModifyGuild (getID -> gid) _) = + baseRoute gid + & buildRoute + route (DeleteGuild (getID -> gid)) = + baseRoute gid + & buildRoute + route (GetGuildChannels (getID -> gid)) = + baseRoute gid + // S "channels" + & buildRoute + route (CreateGuildChannel (getID -> gid) _) = + baseRoute gid + // S "channels" + & buildRoute + route (ModifyGuildChannelPositions (getID -> gid) _) = + baseRoute gid + // S "channels" + & buildRoute + route (GetGuildMember (getID -> gid) (getID @User -> uid)) = + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute + route (ListGuildMembers (getID -> gid) _) = + baseRoute gid + // S "members" + & buildRoute + route (SearchGuildMembers (getID -> gid) _) = + baseRoute gid + // S "members" + // S "search" + & buildRoute + route (AddGuildMember (getID -> gid) (getID @User -> uid) _) = + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute + route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) = + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute + route (ModifyCurrentUserNick (getID -> gid) _) = + baseRoute gid + // S "members" + // S "@me" + // S "nick" + & buildRoute + route (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = + baseRoute gid + // S "members" + // ID @User + // S "roles" + // ID @Role + & giveID uid + & giveID rid + & buildRoute + route (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = + baseRoute gid + // S "members" + // ID @User + // S "roles" + // ID @Role + & giveID uid + & giveID rid + & buildRoute + route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = + baseRoute gid + // S "members" + // ID @User + & giveID uid + & buildRoute + route (GetGuildBans (getID -> gid) _) = + baseRoute gid + // S "bans" + & buildRoute + route (GetGuildBan (getID -> gid) (getID @User -> uid)) = + baseRoute gid + // S "bans" + // ID @User + & giveID uid + & buildRoute + route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) = + baseRoute gid + // S "bans" + // ID @User + & giveID uid + & buildRoute + route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = + baseRoute gid + // S "bans" + // ID @User + & giveID uid + & buildRoute + route (GetGuildRoles (getID -> gid)) = + baseRoute gid + // S "roles" + & buildRoute + route (CreateGuildRole (getID -> gid) _) = + baseRoute gid + // S "roles" + & buildRoute + route (ModifyGuildRolePositions (getID -> gid) _) = + baseRoute gid + // S "roles" + & buildRoute + route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = + baseRoute gid + // S "roles" + // ID @Role + & giveID rid + & buildRoute + route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = + baseRoute gid + // S "roles" + // ID @Role + & giveID rid + & buildRoute + route (GetGuildPruneCount (getID -> gid) _) = + baseRoute gid + // S "prune" + & buildRoute + route (BeginGuildPrune (getID -> gid) _ _) = + baseRoute gid + // S "prune" + & buildRoute + route (GetGuildVoiceRegions (getID -> gid)) = + baseRoute gid + // S "regions" + & buildRoute + route (GetGuildInvites (getID -> gid)) = + baseRoute gid + // S "invites" + & buildRoute + + action (CreateGuild o) = postWith' (ReqBodyJson o) + action (GetGuild _) = getWith + action (ModifyGuild _ o) = patchWith' (ReqBodyJson o) + action (DeleteGuild _) = deleteWith + action (GetGuildChannels _) = getWith + action (CreateGuildChannel _ o) = postWith' (ReqBodyJson o) + action (ModifyGuildChannelPositions _ o) = postWith' (ReqBodyJson o) + action (GetGuildMember _ _) = getWith + action (ListGuildMembers _ ListMembersOptions {limit, after}) = + getWithP + ("limit" =:? limit <> "after" =:? (fromSnowflake <$> after)) + action (SearchGuildMembers _ SearchMembersOptions {limit, query}) = + getWithP + ("limit" =:? limit <> "query" =: query) + action (AddGuildMember _ _ o) = putWith' (ReqBodyJson o) + action (ModifyGuildMember _ _ o) = patchWith' (ReqBodyJson o) + action (ModifyCurrentUserNick _ nick) = patchWith' (ReqBodyJson $ Aeson.object ["nick" Aeson..= nick]) + action AddGuildMemberRole {} = putEmpty + action RemoveGuildMemberRole {} = deleteWith + action (RemoveGuildMember _ _) = deleteWith + action (GetGuildBans _ GetGuildBansOptions {limit, before, after}) = + getWithP + ("limit" =:? limit <> "before" =:? before <> "after" =:? after) + action (GetGuildBan _ _) = getWith + action (CreateGuildBan _ _ CreateGuildBanData {deleteMessageDays}) = + putEmptyP + ("delete_message_days" =:? deleteMessageDays) + action (RemoveGuildBan _ _) = deleteWith + action (GetGuildRoles _) = getWith + action (CreateGuildRole _ o) = postWith' (ReqBodyJson o) + action (ModifyGuildRolePositions _ o) = patchWith' (ReqBodyJson o) + action (ModifyGuildRole _ _ o) = patchWith' (ReqBodyJson o) + action (DeleteGuildRole _ _) = deleteWith + action (GetGuildPruneCount _ d) = getWithP ("days" =: d) + action (BeginGuildPrune _ d r) = postEmptyP ("days" =: d <> "compute_prune_count" =: r) + action (GetGuildVoiceRegions _) = getWith + action (GetGuildInvites _) = getWith + + -- this is a bit of a hack + -- TODO: add something to allow for contextual parsing + modifyResponse _ = Prelude.id + +$(makeFieldLabelsNoPrefix ''CreateGuildData) +$(makeFieldLabelsNoPrefix ''ModifyGuildData) +$(makeFieldLabelsNoPrefix ''ChannelCreateData) +$(makeFieldLabelsNoPrefix ''ChannelPosition) +$(makeFieldLabelsNoPrefix ''ListMembersOptions) +$(makeFieldLabelsNoPrefix ''AddGuildMemberData) +$(makeFieldLabelsNoPrefix ''ModifyGuildRolePositionsData) +$(makeFieldLabelsNoPrefix ''CreateGuildBanData) diff --git a/Calamity/HTTP/Interaction.hs b/Calamity/HTTP/Interaction.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Interaction.hs @@ -0,0 +1,509 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Interaction endpoints +module Calamity.HTTP.Interaction ( + InteractionRequest (..), + InteractionCallbackMessageOptions (..), + InteractionCallbackAutocomplete (..), + InteractionCallbackAutocompleteChoice (..), + InteractionCallbackModal (..), +) where + +import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Types.Model.Channel.Component (Component, CustomID) +import Calamity.Types.Model.Channel.Embed (Embed) +import Calamity.Types.Model.Channel.Message (Message) +import Calamity.Types.Model.Interaction +import Calamity.Types.Snowflake +import Data.Aeson qualified as Aeson +import Data.Bits (shiftL, (.|.)) +import Data.Default.Class +import Data.HashMap.Strict qualified as H +import Data.Maybe (fromMaybe) +import Data.Monoid (First (First, getFirst)) +import Data.Text (Text) +import Data.Text qualified as T +import Network.HTTP.Client.MultipartFormData +import Network.HTTP.Req +import Network.Mime +import Optics + +data InteractionCallback = InteractionCallback + { type_ :: InteractionCallbackType + , data_ :: Maybe Aeson.Value + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallback + +instance CalamityToJSON' InteractionCallback where + toPairs InteractionCallback {..} = + [ "type" .= type_ + , "data" .?= data_ + ] + +data InteractionCallbackMessageOptions = InteractionCallbackMessageOptions + { tts :: Maybe Bool + , content :: Maybe Text + , embeds :: Maybe [Embed] + , allowedMentions :: Maybe AllowedMentions + , ephemeral :: Maybe Bool + , suppressEmbeds :: Maybe Bool + , components :: Maybe [Component] + , attachments :: Maybe [CreateMessageAttachment] + } + deriving (Show) + +instance Default InteractionCallbackMessageOptions where + def = InteractionCallbackMessageOptions Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data CreateMessageAttachmentJson = CreateMessageAttachmentJson + { id :: Int + , filename :: Text + , description :: Maybe Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson + +instance CalamityToJSON' CreateMessageAttachmentJson where + toPairs CreateMessageAttachmentJson {..} = + [ "id" .= id + , "filename" .= filename + , "description" .?= description + ] + +data CreateResponseMessageJson = CreateResponseMessageJson + { tts :: Maybe Bool + , content :: Maybe Text + , embeds :: Maybe [Embed] + , allowedMentions :: Maybe AllowedMentions + , flags :: Maybe Int + , components :: Maybe [Component] + , attachments :: Maybe [CreateMessageAttachmentJson] + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateResponseMessageJson + +instance CalamityToJSON' CreateResponseMessageJson where + toPairs CreateResponseMessageJson {..} = + [ "tts" .?= tts + , "content" .?= content + , "embeds" .?= embeds + , "allowed_mentions" .?= allowedMentions + , "flags" .?= flags + , "components" .?= components + , "attachments" .?= attachments + ] + +newtype InteractionCallbackAutocomplete = InteractionCallbackAutocomplete + { choices :: [InteractionCallbackAutocompleteChoice] + } + deriving stock (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocomplete + +instance CalamityToJSON' InteractionCallbackAutocomplete where + toPairs InteractionCallbackAutocomplete {..} = ["choices" .= choices] + +data InteractionCallbackAutocompleteChoice = InteractionCallbackAutocompleteChoice + { name :: Text + , nameLocalizations :: H.HashMap Text Text + , value :: Aeson.Value + -- ^ Either text or numeric + } + deriving stock (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackAutocompleteChoice + +instance CalamityToJSON' InteractionCallbackAutocompleteChoice where + toPairs InteractionCallbackAutocompleteChoice {..} = + [ "name" .= name + , "name_localizations" .= nameLocalizations + , "value" .= value + ] + +data InteractionCallbackModal = InteractionCallbackModal + { customID :: CustomID + , title :: Text + , components :: [Component] + } + deriving stock (Show) + deriving (Aeson.ToJSON) via CalamityToJSON InteractionCallbackModal + +instance CalamityToJSON' InteractionCallbackModal where + toPairs InteractionCallbackModal {..} = + [ "custom_id" .= customID + , "title" .= title + , "components" .= components + ] + +data InteractionCallbackType + = PongType + | ChannelMessageWithSourceType + | DeferredChannelMessageWithSourceType + | DeferredUpdateMessageType + | UpdateMessageType + | ApplicationCommandAutocompleteResultType + | ModalType + deriving (Show) + +instance Aeson.ToJSON InteractionCallbackType where + toJSON ty = Aeson.toJSON @Int $ case ty of + PongType -> 1 + ChannelMessageWithSourceType -> 4 + DeferredChannelMessageWithSourceType -> 5 + DeferredUpdateMessageType -> 6 + UpdateMessageType -> 7 + ApplicationCommandAutocompleteResultType -> 8 + ModalType -> 9 + toEncoding ty = Aeson.toEncoding @Int $ case ty of + PongType -> 1 + ChannelMessageWithSourceType -> 4 + DeferredChannelMessageWithSourceType -> 5 + DeferredUpdateMessageType -> 6 + UpdateMessageType -> 7 + ApplicationCommandAutocompleteResultType -> 8 + ModalType -> 9 + +$(makeFieldLabelsNoPrefix ''InteractionCallbackMessageOptions) +$(makeFieldLabelsNoPrefix ''InteractionCallbackAutocomplete) +$(makeFieldLabelsNoPrefix ''InteractionCallbackAutocompleteChoice) +$(makeFieldLabelsNoPrefix ''InteractionCallbackModal) + +data InteractionRequest a where + CreateResponseMessage :: + (HasID Interaction i) => + i -> + InteractionToken -> + InteractionCallbackMessageOptions -> + InteractionRequest () + -- | Ack an interaction and defer the response + -- + -- This route triggers the 'thinking' message + CreateResponseDefer :: + (HasID Interaction i) => + i -> + InteractionToken -> + -- | Ephemeral + Bool -> + InteractionRequest () + -- | Ack an interaction and defer the response + -- + -- This route is only usable by component interactions, and doesn't trigger a + -- 'thinking' message + CreateResponseDeferComponent :: + (HasID Interaction i) => + i -> + InteractionToken -> + InteractionRequest () + CreateResponseUpdate :: + (HasID Interaction i) => + i -> + InteractionToken -> + InteractionCallbackMessageOptions -> + InteractionRequest () + CreateResponseAutocomplete :: + (HasID Interaction i) => + i -> + InteractionToken -> + InteractionCallbackAutocomplete -> + InteractionRequest () + CreateResponseModal :: + (HasID Interaction i) => + i -> + InteractionToken -> + InteractionCallbackModal -> + InteractionRequest () + GetOriginalInteractionResponse :: + (HasID Application i) => + i -> + InteractionToken -> + InteractionRequest Message + EditOriginalInteractionResponse :: + (HasID Application i) => + i -> + InteractionToken -> + InteractionCallbackMessageOptions -> + InteractionRequest Message + DeleteOriginalInteractionResponse :: + (HasID Application i) => + i -> + InteractionToken -> + InteractionRequest () + CreateFollowupMessage :: + (HasID Application i) => + i -> + InteractionToken -> + InteractionCallbackMessageOptions -> + InteractionRequest () + GetFollowupMessage :: + (HasID Application i, HasID Message m) => + i -> + m -> + InteractionToken -> + InteractionRequest Message + EditFollowupMessage :: + (HasID Application i, HasID Message m) => + i -> + m -> + InteractionToken -> + InteractionCallbackMessageOptions -> + InteractionRequest () + DeleteFollowupMessage :: + (HasID Application i, HasID Message m) => + i -> + m -> + InteractionToken -> + InteractionRequest () + +baseRoute :: Snowflake Application -> InteractionToken -> RouteBuilder _ +baseRoute id (InteractionToken token) = + mkRouteBuilder + // S "webhooks" + // ID @Application + // S token + & giveID id + +foo :: Maybe a -> Maybe a -> (a -> a -> a) -> Maybe a +foo (Just x) (Just y) f = Just (f x y) +foo x y _ = getFirst $ First x <> First y + +instance Request (InteractionRequest a) where + type Result (InteractionRequest a) = a + + route (CreateResponseDefer (getID @Interaction -> iid) (InteractionToken token) _) = + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute + route (CreateResponseDeferComponent (getID @Interaction -> iid) (InteractionToken token)) = + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute + route (CreateResponseMessage (getID @Interaction -> iid) (InteractionToken token) _) = + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute + route (CreateResponseUpdate (getID @Interaction -> iid) (InteractionToken token) _) = + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute + route (CreateResponseAutocomplete (getID @Interaction -> iid) (InteractionToken token) _) = + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute + route (CreateResponseModal (getID @Interaction -> iid) (InteractionToken token) _) = + mkRouteBuilder + // S "interactions" + // ID @Interaction + // S token + // S "callback" + & giveID iid + & buildRoute + route (GetOriginalInteractionResponse (getID @Application -> aid) token) = + baseRoute aid token // S "messages" // S "@original" & buildRoute + route (EditOriginalInteractionResponse (getID @Application -> aid) token _) = + baseRoute aid token // S "messages" // S "@original" & buildRoute + route (DeleteOriginalInteractionResponse (getID @Application -> aid) token) = + baseRoute aid token // S "messages" // S "@original" & buildRoute + route (CreateFollowupMessage (getID @Application -> aid) token _) = + baseRoute aid token & buildRoute + route (GetFollowupMessage (getID @Application -> aid) (getID @Message -> mid) token) = + baseRoute aid token // S "messages" // ID @Message & giveID mid & buildRoute + route (EditFollowupMessage (getID @Application -> aid) (getID @Message -> mid) token _) = + baseRoute aid token // S "messages" // ID @Message & giveID mid & buildRoute + route (DeleteFollowupMessage (getID @Application -> aid) (getID @Message -> mid) token) = + baseRoute aid token // S "messages" // ID @Message & giveID mid & buildRoute + + action (CreateResponseDefer _ _ ephemeral) = + let jsonBody = + InteractionCallback + { type_ = DeferredChannelMessageWithSourceType + , data_ = if ephemeral then Just . Aeson.object $ [("flags", Aeson.Number 64)] else Nothing + } + in postWith' (ReqBodyJson jsonBody) + action (CreateResponseDeferComponent _ _) = + let jsonBody = + InteractionCallback + { type_ = DeferredUpdateMessageType + , data_ = Nothing + } + in postWith' (ReqBodyJson jsonBody) + action (CreateResponseMessage _ _ cm) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] + attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments + ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral + suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds + flags = foo ephemeral suppressEmbeds (.|.) + jsonData = + CreateResponseMessageJson + { content = cm ^. #content + , tts = cm ^. #tts + , embeds = cm ^. #embeds + , allowedMentions = cm ^. #allowedMentions + , components = cm ^. #components + , attachments = attachments + , flags = flags + } + jsonBody = + InteractionCallback + { type_ = ChannelMessageWithSourceType + , data_ = Just . Aeson.toJSON $ jsonData + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) + postWith' body u o + action (CreateResponseUpdate _ _ cm) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] + attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments + ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral + suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds + flags = foo ephemeral suppressEmbeds (.|.) + jsonData = + CreateResponseMessageJson + { content = cm ^. #content + , tts = cm ^. #tts + , embeds = cm ^. #embeds + , allowedMentions = cm ^. #allowedMentions + , components = cm ^. #components + , attachments = attachments + , flags = flags + } + jsonBody = + InteractionCallback + { type_ = UpdateMessageType + , data_ = Just . Aeson.toJSON $ jsonData + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) + postWith' body u o + action (CreateResponseAutocomplete _ _ ao) = + let jsonBody = + InteractionCallback + { type_ = ApplicationCommandAutocompleteResultType + , data_ = Just . Aeson.toJSON $ ao + } + in postWith' (ReqBodyJson jsonBody) + action (CreateResponseModal _ _ mo) = + let jsonBody = + InteractionCallback + { type_ = ModalType + , data_ = Just . Aeson.toJSON $ mo + } + in postWith' (ReqBodyJson jsonBody) + action (GetOriginalInteractionResponse _ _) = getWith + action (EditOriginalInteractionResponse _ _ cm) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] + attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments + ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral + suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds + flags = foo ephemeral suppressEmbeds (.|.) + jsonData = + CreateResponseMessageJson + { content = cm ^. #content + , tts = cm ^. #tts + , embeds = cm ^. #embeds + , allowedMentions = cm ^. #allowedMentions + , components = cm ^. #components + , attachments = attachments + , flags = flags + } + jsonBody = + InteractionCallback + { type_ = UpdateMessageType + , data_ = Just . Aeson.toJSON $ jsonData + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) + patchWith' body u o + action (DeleteOriginalInteractionResponse _ _) = deleteWith + action (CreateFollowupMessage _ _ cm) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] + attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments + ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral + suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds + flags = foo ephemeral suppressEmbeds (.|.) + jsonData = + CreateResponseMessageJson + { content = cm ^. #content + , tts = cm ^. #tts + , embeds = cm ^. #embeds + , allowedMentions = cm ^. #allowedMentions + , components = cm ^. #components + , attachments = attachments + , flags = flags + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonData) : files) + postWith' body u o + action GetFollowupMessage {} = getWith + action (EditFollowupMessage _ _ _ cm) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (fromMaybe [] $ cm ^. #attachments) [(0 :: Int) ..] + attachments = (\a -> zipWith attachmentPart a [0 ..]) <$> cm ^. #attachments + ephemeral = (\f -> if f then 1 `shiftL` 6 else 0) <$> cm ^. #ephemeral + suppressEmbeds = (\f -> if f then 1 `shiftL` 2 else 0) <$> cm ^. #suppressEmbeds + flags = foo ephemeral suppressEmbeds (.|.) + jsonData = + CreateResponseMessageJson + { content = cm ^. #content + , tts = cm ^. #tts + , embeds = cm ^. #embeds + , allowedMentions = cm ^. #allowedMentions + , components = cm ^. #components + , attachments = attachments + , flags = flags + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonData) : files) + patchWith' body u o + action DeleteFollowupMessage {} = deleteWith diff --git a/Calamity/HTTP/Internal/Ratelimit.hs b/Calamity/HTTP/Internal/Ratelimit.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Internal/Ratelimit.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Module containing ratelimit stuff +module Calamity.HTTP.Internal.Ratelimit ( + newRateLimitState, + doRequest, + RatelimitEff (..), + getRatelimitState, +) where + +import Calamity.HTTP.Internal.Route +import Calamity.HTTP.Internal.Types +import Calamity.Internal.Utils +import Calamity.Types.LogEff +import Calamity.Types.TokenEff +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Event (Event) +import Control.Concurrent.Event qualified as E +import Control.Concurrent.STM +import Control.Exception.Safe qualified as Ex +import Control.Monad +import Data.Aeson qualified as Aeson +import Data.Aeson.Optics +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as LB +import Data.Maybe +import Data.Text qualified as T +import Data.Time +import Data.Time.Clock.POSIX +import Network.HTTP.Client (responseStatus) +import Network.HTTP.Req +import Network.HTTP.Types +import Optics +import Optics.Operators.Unsafe ((^?!)) +import Polysemy (Sem, makeSem) +import Polysemy qualified as P +import StmContainers.Map qualified as SC +import Prelude hiding (error) +import Prelude qualified + +data RatelimitEff m a where + GetRatelimitState :: RatelimitEff m RateLimitState + +makeSem ''RatelimitEff + +newRateLimitState :: IO RateLimitState +newRateLimitState = RateLimitState <$> SC.newIO <*> SC.newIO <*> E.newSet + +data Ratelimit + = KnownRatelimit Bucket + | UnknownRatelimit RouteKey + +getRateLimit :: RateLimitState -> RouteKey -> STM Ratelimit +getRateLimit s h = do + bucketKey <- SC.lookup h $ bucketKeys s + bucket <- join <$> traverse (`SC.lookup` buckets s) bucketKey + case bucket of + Just bucket' -> + pure $ KnownRatelimit bucket' + Nothing -> + pure $ UnknownRatelimit h + +mergeBucketStates :: BucketState -> BucketState -> BucketState +mergeBucketStates old new = + new + { ongoing = old ^. #ongoing + , -- we only ignore the previous 'remaining' if we've not reset yet and the + -- reset time has changed + remaining = + if isJust (old ^. #resetTime) && old ^. #resetKey /= new ^. #resetKey + then min (old ^. #remaining) (new ^. #remaining) + else new ^. #remaining + , -- only take the new resetTime if it actually changed + resetTime = + if old ^. #resetKey /= new ^. #resetKey + then new ^. #resetTime + else old ^. #resetTime + } + +updateKnownBucket :: Bucket -> BucketState -> STM () +updateKnownBucket bucket bucketState = modifyTVar' (bucket ^. #state) (`mergeBucketStates` bucketState) + +{- | Knowing the bucket for a route, and the ratelimit info, map the route to + the bucket key and retrieve the bucket +-} +updateBucket :: RateLimitState -> RouteKey -> B.ByteString -> BucketState -> STM Bucket +updateBucket s h b bucketState = do + bucketKey <- SC.lookup h $ bucketKeys s + case bucketKey of + Just bucketKey' -> do + -- if we know the bucket key here, then the bucket has already been made + -- if the given bucket key is different than the known bucket key then oops + bucket <- SC.lookup bucketKey' $ buckets s + case bucket of + Just bucket' -> do + modifyTVar' (bucket' ^. #state) (`mergeBucketStates` bucketState) + pure bucket' + Nothing -> Prelude.error "Not possible" + Nothing -> do + -- we didn't know the key to this bucket, but we might know the bucket + -- if we truly don't know the bucket, then make a new one + bs <- do + bucket <- SC.lookup b $ buckets s + case bucket of + Just bs -> pure bs + Nothing -> do + bs <- Bucket <$> newTVar bucketState + SC.insert bs b $ buckets s + pure bs + + SC.insert b h $ bucketKeys s + pure bs + +resetBucket :: Bucket -> STM () +resetBucket bucket = + modifyTVar' + (bucket ^. #state) + ( \bs -> + bs + & #remaining + .~ bs + ^. #limit + & #resetTime + .~ Nothing + ) + +canResetBucketNow :: UTCTime -> BucketState -> Bool +canResetBucketNow _ BucketState {ongoing} | ongoing > 0 = False +-- don't allow resetting the bucket if there's ongoing requests, we'll wait +-- until another request finishes and updates the counter +canResetBucketNow now bs = case bs ^. #resetTime of + Just rt -> now > rt + Nothing -> False + +-- canResetBucket :: BucketState -> Bool +-- canResetBucket bs = isNothing $ bs ^. #startedWaitingTime + +shouldWaitForUnlock :: BucketState -> Bool +shouldWaitForUnlock BucketState {remaining = 0, ongoing} = ongoing > 0 +shouldWaitForUnlock _ = False + +data WaitDelay + = WaitUntil UTCTime + | WaitRetrySoon + | GoNow + deriving (Show) + +intoWaitDelay :: Maybe UTCTime -> WaitDelay +intoWaitDelay (Just t) = WaitUntil t +intoWaitDelay Nothing = WaitRetrySoon + +-- | Maybe wait for a bucket, updating its state to say we used it +useBucketOnce :: Bucket -> IO () +useBucketOnce bucket = go 0 + where + go :: Int -> IO () + go tries = do + now <- getCurrentTime + mWaitDelay <- atomically $ do + s <- readTVar $ bucket ^. #state + + -- -- [0] + -- -- if there are ongoing requests, wait for them to finish and deliver + -- -- truth on the current ratelimit state + when + (shouldWaitForUnlock s) + retry + + -- if there are no ongoing requests, and the bucket reset time has lapsed, + -- we can just reset the bucket. + -- + -- if we've already reset the bucket then there should be an ongoing + -- request so we'll just end up waiting for that to finish + when + (canResetBucketNow now s) + (resetBucket bucket) + + s <- readTVar $ bucket ^. #state + + if s ^. #remaining - s ^. #ongoing > 0 + then do + -- there are tokens remaining for us to use + modifyTVar' + (bucket ^. #state) + ( (#remaining %~ pred) + . (#ongoing %~ succ) + ) + pure GoNow + else do + -- the bucket has expired, there are no ongoing requests because of + -- [0] wait and then retry after we can unlock the bucket + pure (intoWaitDelay $ s ^. #resetTime) + + case mWaitDelay of + WaitUntil waitUntil -> do + if waitUntil < now + then threadDelayMS 20 + else -- if the reset is in the past, we're fucked + threadDelayUntil waitUntil + -- 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 + when (tries < 50) $ go (tries + 1) -- print "bailing after number of retries" + WaitRetrySoon -> do + threadDelayMS 20 + when (tries < 50) $ go (tries + 1) -- print "bailing after number of retries" + GoNow -> do + -- print "ok going forward with request" + pure () + +doDiscordRequest :: (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => IO LbsResponse -> Sem r DiscordResponseType +doDiscordRequest r = do + r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException) + case r'' of + Right r' -> do + 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 + | 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) + | statusIsClientError status -> do + 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) + Left e -> do + error . T.pack $ "Something went wrong with the http client: " <> e + pure . InternalResponseError $ T.pack e + +-- | Parse a ratelimit header returning when it unlocks +parseRateLimitHeader :: (HttpResponse r) => UTCTime -> r -> Maybe UTCTime +parseRateLimitHeader now r = computedEnd <|> end + where + computedEnd :: Maybe UTCTime + computedEnd = flip addUTCTime now <$> resetAfter + + resetAfter :: Maybe NominalDiffTime + resetAfter = realToFrac <$> responseHeader r "X-Ratelimit-Reset-After" ^? _Just % _Double + + end :: Maybe UTCTime + end = + posixSecondsToUTCTime + . realToFrac + <$> responseHeader r "X-Ratelimit-Reset" + ^? _Just + % _Double + +buildBucketState :: (HttpResponse r) => UTCTime -> r -> Maybe (BucketState, B.ByteString) +buildBucketState now r = (,) <$> bs <*> bucketKey + where + remaining = responseHeader r "X-RateLimit-Remaining" ^? _Just % _Integral + limit = responseHeader r "X-RateLimit-Limit" ^? _Just % _Integral + resetKey = ceiling <$> responseHeader r "X-RateLimit-Reset" ^? _Just % _Double + resetTime = parseRateLimitHeader now r + bs = BucketState resetTime <$> resetKey <*> remaining <*> limit <*> pure 0 + bucketKey = responseHeader r "X-RateLimit-Bucket" + +-- | Parse the retry after field, returning when to retry +parseRetryAfter :: UTCTime -> Aeson.Value -> UTCTime +parseRetryAfter now r = addUTCTime retryAfter now + where + retryAfter = realToFrac $ r ^?! key "retry_after" % _Double + +isGlobal :: Aeson.Value -> Bool +isGlobal r = r ^? key "global" % _Bool == Just True + +-- Either (Either a a) b +data ShouldRetry a b + = Retry a + | RFail a + | RGood b + +retryRequest :: + (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => + -- | number of retries + Int -> + -- | action to perform + Sem r (ShouldRetry a b) -> + Sem r (Either a b) +retryRequest maxRetries action = retryInner 0 + where + retryInner numRetries = do + res <- action + case res of + Retry r | numRetries > maxRetries -> do + debug . T.pack $ "Request failed after " <> show maxRetries <> " retries" + pure $ Left r + Retry _ -> + retryInner (numRetries + 1) + RFail r -> do + debug "Request failed due to error response" + pure $ Left r + RGood r -> + pure $ Right r + +threadDelayMS :: Int -> IO () +threadDelayMS ms = threadDelay (1000 * ms) + +tenMS :: NominalDiffTime +tenMS = 0.01 + +threadDelayUntil :: UTCTime -> IO () +threadDelayUntil when = do + let when' = addUTCTime tenMS when -- lol + now <- getCurrentTime + let msUntil = ceiling . (* 1000) . realToFrac @_ @Double $ diffUTCTime when' now + threadDelayMS msUntil + +-- Run a single request +doSingleRequest :: + (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => + RateLimitState -> + Route -> + -- | Global lock + Event -> + -- | Request action + IO LbsResponse -> + Sem r (ShouldRetry RestError LB.ByteString) +doSingleRequest rlstate route gl r = do + P.embed $ E.wait (globalLock rlstate) + + rl <- P.embed . atomically $ getRateLimit rlstate (routeKey route) + + case rl of + KnownRatelimit bucket -> + P.embed $ useBucketOnce bucket + _ -> debug "unknown ratelimit" + + r' <- doDiscordRequest r + + case r' of + Good v rlHeaders -> do + void . P.embed . atomically $ do + case rl of + KnownRatelimit bucket -> + modifyTVar' (bucket ^. #state) (#ongoing %~ pred) + _ -> pure () + case (rl, rlHeaders) of + (KnownRatelimit bucket, Just (bs, _bk)) -> + updateKnownBucket bucket bs + (_, Just (bs, bk)) -> + 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 + + P.embed . atomically $ do + case rl of + KnownRatelimit bucket -> do + modifyTVar' (bucket ^. #state) (#ongoing %~ pred) + updateKnownBucket bucket bs + _ -> void $ updateBucket rlstate (routeKey route) bk bs + + P.embed $ do + threadDelayUntil unlockWhen + + pure $ Retry (HTTPError 429 Nothing) + Ratelimited unlockWhen False _ -> do + debug "Internal error (ratelimited but no headers), retrying" + case rl of + KnownRatelimit bucket -> + void . P.embed . atomically $ modifyTVar' (bucket ^. #state) (#ongoing %~ pred) + _ -> pure () + + P.embed $ threadDelayUntil unlockWhen + pure $ Retry (HTTPError 429 Nothing) + Ratelimited unlockWhen True bs -> do + debug "429 ratelimited globally" + + P.embed $ do + atomically $ do + case rl of + KnownRatelimit bucket -> + modifyTVar' (bucket ^. #state) (#ongoing %~ pred) + _ -> pure () + case bs of + Just (bs', bk) -> + void $ updateBucket rlstate (routeKey route) bk bs' + Nothing -> + pure () + + E.clear gl + threadDelayUntil unlockWhen + E.set gl + pure $ Retry (HTTPError 429 Nothing) + ServerError c -> do + debug "Server failed, retrying" + case rl of + KnownRatelimit bucket -> + P.embed $ useBucketOnce bucket + _ -> debug "unknown ratelimit" + pure $ Retry (HTTPError c Nothing) + InternalResponseError c -> do + debug "Internal error, retrying" + case rl of + KnownRatelimit bucket -> + P.embed $ useBucketOnce bucket + _ -> debug "unknown ratelimit" + pure $ Retry (InternalClientError c) + ClientError c v -> do + case rl of + KnownRatelimit bucket -> + P.embed $ useBucketOnce bucket + _ -> debug "unknown ratelimit" + pure $ RFail (HTTPError c $ Aeson.decode v) + +doRequest :: (P.Members '[RatelimitEff, TokenEff, LogEff, P.Embed IO] r) => RateLimitState -> Route -> IO LbsResponse -> Sem r (Either RestError LB.ByteString) +doRequest rlstate route action = + retryRequest + 5 + (doSingleRequest rlstate route (globalLock rlstate) action) diff --git a/Calamity/HTTP/Internal/Request.hs b/Calamity/HTTP/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Internal/Request.hs @@ -0,0 +1,146 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | Generic Request type +module Calamity.HTTP.Internal.Request ( + Request (..), + invoke, + getWith, + postWith', + postWithP', + putWith', + patchWith', + putEmpty, + putEmptyP, + postEmpty, + postEmptyP, + getWithP, + deleteWith, + (=:?), +) where + +import Calamity.HTTP.Internal.Ratelimit +import Calamity.HTTP.Internal.Route +import Calamity.HTTP.Internal.Types +import Calamity.Metrics.Eff +import Calamity.Types.LogEff (LogEff) +import Calamity.Types.Token +import Calamity.Types.TokenEff +import Control.Monad +import Data.Aeson hiding (Options) +import Data.Aeson.Types (parseEither) +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 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 +throwIfLeft (Right a) = pure a +throwIfLeft (Left e) = P.throw (InternalClientError . T.pack $ e) + +extractRight :: (P.Member (P.Error e) r) => Either e a -> P.Sem r a +extractRight (Left e) = P.throw e +extractRight (Right a) = pure a + +class ReadResponse a where + processResp :: LB.ByteString -> (Value -> Value) -> Either String a + +instance {-# OVERLAPPABLE #-} (FromJSON a) => ReadResponse a where + processResp s f = eitherDecode s >>= parseEither parseJSON . f + +instance ReadResponse () where + processResp _ _ = Right () + +class Request a where + type Result a + + route :: a -> Route + + action :: a -> Url 'Https -> Option 'Https -> Req LbsResponse + + modifyResponse :: a -> Value -> Value + modifyResponse _ = id + +invoke :: + ( P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r + , Request a + , ReadResponse (Calamity.HTTP.Internal.Request.Result a) + ) => + a -> + P.Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a)) +invoke a = do + rlState' <- getRatelimitState + token' <- getBotToken + + let route' = route a + + inFlightRequests <- registerGauge "inflight_requests" [("route", renderUrl $ route' ^. #path)] + totalRequests <- registerCounter "total_requests" [("route", renderUrl $ route' ^. #path)] + void $ modifyGauge (+ 1) inFlightRequests + void $ addCounter 1 totalRequests + + let r = action a (route' ^. #path) (requestOptions token') + act = runReq reqConfig r + + resp <- push "calamity" . attr "route" (renderUrl $ route' ^. #path) $ doRequest rlState' route' act + + void $ modifyGauge (subtract 1) inFlightRequests + + P.runError $ do + s <- extractRight resp + throwIfLeft $ processResp s (modifyResponse a) + +reqConfig :: HttpConfig +reqConfig = + defaultHttpConfig + { httpConfigCheckResponse = \_ _ _ -> Nothing + } + +defaultRequestOptions :: Option 'Https +defaultRequestOptions = + header "User-Agent" "Calamity (https://github.com/simmsb/calamity)" + <> header "X-RateLimit-Precision" "millisecond" + +requestOptions :: Token -> Option 'Https +requestOptions t = defaultRequestOptions <> header "Authorization" (TS.encodeUtf8 $ formatToken t) + +getWith :: Url 'Https -> Option 'Https -> Req LbsResponse +getWith u = req GET u NoReqBody lbsResponse + +postWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse +postWith' a u = req POST u a lbsResponse + +postWithP' :: (HttpBody a) => a -> Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +postWithP' a o u o' = req POST u a lbsResponse (o <> o') + +postEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse +postEmpty u = req POST u NoReqBody lbsResponse + +putWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse +putWith' a u = req PUT u a lbsResponse + +patchWith' :: (HttpBody a) => a -> Url 'Https -> Option 'Https -> Req LbsResponse +patchWith' a u = req PATCH u a lbsResponse + +putEmpty :: Url 'Https -> Option 'Https -> Req LbsResponse +putEmpty u = req PUT u NoReqBody lbsResponse + +putEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +putEmptyP o u o' = req PUT u NoReqBody lbsResponse (o <> o') + +postEmptyP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +postEmptyP o u o' = req POST u NoReqBody lbsResponse (o <> o') + +getWithP :: Option 'Https -> Url 'Https -> Option 'Https -> Req LbsResponse +getWithP o u o' = req GET u NoReqBody lbsResponse (o <> o') + +deleteWith :: Url 'Https -> Option 'Https -> Req LbsResponse +deleteWith u = req DELETE u NoReqBody lbsResponse + +(=:?) :: (ToHttpApiData a) => T.Text -> Maybe a -> Option 'Https +n =:? (Just x) = n =: x +_ =:? Nothing = mempty diff --git a/Calamity/HTTP/Internal/Route.hs b/Calamity/HTTP/Internal/Route.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Internal/Route.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +{- | The route type + Why I did this I don't know +-} +module Calamity.HTTP.Internal.Route ( + mkRouteBuilder, + giveID, + giveParam, + buildRoute, + routeKey, + RouteKey, + RouteBuilder, + RouteRequirement, + Route (path), + S (..), + PS (..), + ID (..), + RouteFragmentable (..), +) where + +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake +import Data.Hashable +import Data.Kind +import Data.List (foldl') +import Data.Maybe (fromJust) +import Data.Text (Text) +import 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 TextShow qualified + +data RouteFragment + = -- | Static string fragment + S' Text + | -- | Parameterised string fragment + PS' String + | -- | ID fragment + ID' TypeRep + deriving (Generic, Show, Eq) + +-- | A static string fragment of a route +newtype S = S Text + +-- | A parameterised string fragment of a route +data PS (s :: Symbol) = PS + +-- | An id fragment of a route +data ID a = ID + +instance Hashable RouteFragment + +data RouteRequirement + = NotNeeded + | Required + | Satisfied + deriving (Show, Eq) + +data RequirementType + = IDRequirement Type + | PSRequirement Symbol + +data RouteBuilder (reqstate :: [(RequirementType, RouteRequirement)]) = UnsafeMkRouteBuilder + { route :: [RouteFragment] + , ids :: [(TypeRep, Word64)] + , params :: [(String, Text)] + } + +mkRouteBuilder :: RouteBuilder '[] +mkRouteBuilder = UnsafeMkRouteBuilder [] [] [] + +giveID :: + forall t reqs. + (Typeable t) => + Snowflake t -> + RouteBuilder reqs -> + RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs) +giveID (Snowflake id) (UnsafeMkRouteBuilder route ids params) = + UnsafeMkRouteBuilder route ((typeRep $ Proxy @t, id) : ids) params + +giveParam :: + forall (s :: Symbol) reqs. + (KnownSymbol s) => + Text -> + RouteBuilder reqs -> + RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs) +giveParam value (UnsafeMkRouteBuilder route ids params) = + UnsafeMkRouteBuilder route ids ((symbolVal $ Proxy @s, value) : params) + +type family (&&) (a :: Bool) (b :: Bool) :: Bool where + 'True && 'True = 'True + _ && _ = 'False + +type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where + Lookup k ('(k, v) ': xs) = 'Just v + Lookup k ('(_, v) ': xs) = Lookup k xs + Lookup _ '[] = 'Nothing + +type family IsElem (x :: k) (l :: [k]) :: Bool where + IsElem _ '[] = 'False + IsElem k (k : _) = 'True + IsElem k (_ : xs) = IsElem k xs + +type family EnsureFulfilled (reqs :: [(RequirementType, RouteRequirement)]) :: Constraint where + EnsureFulfilled reqs = EnsureFulfilledInner reqs '[] 'True + +type family EnsureFulfilledInner (reqs :: [(RequirementType, RouteRequirement)]) (seen :: [RequirementType]) (ok :: Bool) :: Constraint where + EnsureFulfilledInner '[] _ 'True = () + EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok + EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok + EnsureFulfilledInner ('(k, 'Required) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok) + +type family AddRequired k (reqs :: [(RequirementType, RouteRequirement)]) :: [(RequirementType, RouteRequirement)] where + AddRequired k reqs = '(k, AddRequiredInner (Lookup k reqs)) ': reqs + +type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where + AddRequiredInner ('Just 'Required) = 'Required + AddRequiredInner ('Just 'Satisfied) = 'Satisfied + AddRequiredInner ('Just 'NotNeeded) = 'Required + AddRequiredInner 'Nothing = 'Required + +class (Typeable a) => RouteFragmentable a reqs where + type ConsRes a reqs + + (//) :: RouteBuilder reqs -> a -> ConsRes a reqs + +instance RouteFragmentable S reqs where + type ConsRes S reqs = RouteBuilder reqs + + (UnsafeMkRouteBuilder r ids params) // (S t) = + 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) + + (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) + + (UnsafeMkRouteBuilder r ids params) // PS = + UnsafeMkRouteBuilder (r <> [PS' $ symbolVal $ Proxy @s]) ids params + +infixl 5 // + +data Route = Route + { path :: Url 'Https + , key :: Text + , channelID :: Maybe (Snowflake Channel) + , guildID :: Maybe (Snowflake Guild) + } + deriving (Show) + +type RouteKey = (Text, Maybe (Snowflake Channel), Maybe (Snowflake Guild)) + +routeKey :: Route -> RouteKey +routeKey Route {key, channelID, guildID} = (key, channelID, guildID) + +baseURL :: Url 'Https +baseURL = https "discord.com" /: "api" /: "v10" + +buildRoute :: + forall (reqs :: [(RequirementType, RouteRequirement)]). + (EnsureFulfilled reqs) => + RouteBuilder reqs -> + Route +buildRoute (UnsafeMkRouteBuilder route ids params) = + Route + (foldl' (/:) baseURL $ map goRoute route) + (T.concat (map goKey route)) + (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids) + (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids) + where + goRoute (S' t) = t + goRoute (PS' t) = fromJust $ lookup t params + goRoute (ID' t) = TextShow.showt . fromJust $ lookup t ids + + goKey (S' t) = t + goKey (PS' t) = T.pack t + goKey (ID' t) = TextShow.showt t + +$(makeFieldLabelsNoPrefix ''Route) diff --git a/Calamity/HTTP/Internal/Types.hs b/Calamity/HTTP/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Internal/Types.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Types for the http lib +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 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 Optics.TH +import StmContainers.Map qualified as SC + +data RestError + = -- | 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) + +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 + , remaining :: Int + -- ^ The number of uses left in the bucket, used to heuristically wait out ratelimits + , limit :: Int + -- ^ The total number of uses for this bucket + , ongoing :: Int + -- ^ How many ongoing requests + } + deriving (Show) + +newtype Bucket = Bucket + { state :: TVar BucketState + } + +data RateLimitState = RateLimitState + { bucketKeys :: SC.Map RouteKey B.ByteString + , buckets :: SC.Map B.ByteString Bucket + , globalLock :: Event + } + +data DiscordResponseType + = -- | A good response + Good + LB.ByteString + -- | The ratelimit headers if we got them + (Maybe (BucketState, B.ByteString)) + | -- | We hit a 429, no response and ratelimited + Ratelimited + -- | Retry after + UTCTime + -- | Global ratelimit + Bool + (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) + +instance Aeson.FromJSON GatewayResponse where + parseJSON = Aeson.withObject "GatewayResponse" $ \v -> + GatewayResponse <$> v .: "url" + +data BotGatewayResponse = BotGatewayResponse + { url :: T.Text + , shards :: Int + } + deriving (Show) + +instance Aeson.FromJSON BotGatewayResponse where + parseJSON = Aeson.withObject "BotGatewayResponse" $ \v -> + BotGatewayResponse + <$> v .: "url" + <*> v .: "shards" + +$(makeFieldLabelsNoPrefix ''Bucket) +$(makeFieldLabelsNoPrefix ''BucketState) +$(makeFieldLabelsNoPrefix ''RateLimitState) +$(makeFieldLabelsNoPrefix ''GatewayResponse) +$(makeFieldLabelsNoPrefix ''BotGatewayResponse) diff --git a/Calamity/HTTP/Invite.hs b/Calamity/HTTP/Invite.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Invite.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Invite endpoints +module Calamity.HTTP.Invite (InviteRequest (..)) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Types.Model.Guild +import Data.Function ((&)) +import Data.Text (Text) +import Network.HTTP.Req + +data InviteRequest a where + GetInvite :: Text -> InviteRequest Invite + DeleteInvite :: Text -> InviteRequest () + +baseRoute :: RouteBuilder _ +baseRoute = mkRouteBuilder // S "invites" + +instance Request (InviteRequest a) where + type Result (InviteRequest a) = a + + route (GetInvite c) = + baseRoute // PS @"invite" + & giveParam @"invite" c + & buildRoute + route (DeleteInvite c) = + baseRoute // PS @"invite" + & giveParam @"invite" c + & buildRoute + + action (GetInvite _) = getWithP ("with_counts" =: True) + action (DeleteInvite _) = deleteWith diff --git a/Calamity/HTTP/MiscRoutes.hs b/Calamity/HTTP/MiscRoutes.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/MiscRoutes.hs @@ -0,0 +1,24 @@ +-- | Miscellaneous routes +module Calamity.HTTP.MiscRoutes where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.HTTP.Internal.Types +import Data.Function ((&)) + +data MiscRequest a where + GetGateway :: MiscRequest GatewayResponse + GetGatewayBot :: MiscRequest BotGatewayResponse + +instance Request (MiscRequest a) where + type Result (MiscRequest a) = a + + route GetGateway = + mkRouteBuilder // S "gateway" + & buildRoute + route GetGatewayBot = + mkRouteBuilder // S "gateway" // S "bot" + & buildRoute + + action GetGateway = getWith + action GetGatewayBot = getWith diff --git a/Calamity/HTTP/Reason.hs b/Calamity/HTTP/Reason.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Reason.hs @@ -0,0 +1,24 @@ +-- | A wrapper request that adds a reson to a request +module Calamity.HTTP.Reason ( + Reason (..), + reason, +) where + +import Calamity.HTTP.Internal.Request +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Req + +data Reason a = Reason a Text + deriving (Show, Eq) + +-- | Attach a reason to a request +reason :: (Request a) => Text -> a -> Reason a +reason = flip Reason + +instance (Request a) => Request (Reason a) where + type Result (Reason a) = Result a + + route (Reason a _) = route a + + 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 new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/User.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | User endpoints +module Calamity.HTTP.User ( + UserRequest (..), + ModifyUserData (..), + GetCurrentUserGuildsOptions (..), +) where + +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.?=)) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson qualified as Aeson +import Data.Default.Class +import Data.Function ((&)) +import Data.Text (Text) +import Network.HTTP.Req +import Optics.TH + +data ModifyUserData = ModifyUserData + { username :: 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 + +instance CalamityToJSON' ModifyUserData where + toPairs ModifyUserData {..} = + [ "username" .?= username + , "avatar" .?= avatar + ] + +instance Default ModifyUserData where + def = ModifyUserData Nothing Nothing + +data GetCurrentUserGuildsOptions = GetCurrentUserGuildsOptions + { before :: Maybe (Snowflake Guild) + , after :: Maybe (Snowflake Guild) + , limit :: Maybe Integer + } + deriving (Show) + +instance Default GetCurrentUserGuildsOptions where + def = GetCurrentUserGuildsOptions Nothing Nothing Nothing + +data UserRequest a where + GetCurrentUser :: UserRequest User + GetUser :: (HasID User u) => u -> UserRequest User + ModifyCurrentUser :: ModifyUserData -> UserRequest User + GetCurrentUserGuilds :: GetCurrentUserGuildsOptions -> UserRequest [Partial Guild] + LeaveGuild :: (HasID Guild g) => g -> UserRequest () + CreateDM :: (HasID User u) => u -> UserRequest DMChannel + +baseRoute :: RouteBuilder _ +baseRoute = mkRouteBuilder // S "users" // S "@me" + +instance Request (UserRequest a) where + type Result (UserRequest a) = a + + route GetCurrentUser = + baseRoute + & buildRoute + route (GetUser (getID @User -> uid)) = + mkRouteBuilder // S "users" // ID @User + & giveID uid + & buildRoute + route (ModifyCurrentUser _) = + baseRoute + & buildRoute + route (GetCurrentUserGuilds _) = + baseRoute // S "guilds" + & buildRoute + route (LeaveGuild (getID @Guild -> gid)) = + baseRoute // S "guilds" // ID @Guild + & giveID gid + & buildRoute + route (CreateDM _) = + baseRoute // S "channels" + & buildRoute + + action GetCurrentUser = getWith + action (GetUser _) = getWith + action (ModifyCurrentUser o) = patchWith' $ ReqBodyJson o + action (GetCurrentUserGuilds GetCurrentUserGuildsOptions {before, after, limit}) = + getWithP + ( "before" =:? (fromSnowflake <$> before) + <> "after" =:? (fromSnowflake <$> after) + <> "limit" =:? limit + ) + action (LeaveGuild _) = deleteWith + action (CreateDM (getID @User -> uid)) = postWith' $ ReqBodyJson (Aeson.object ["recipient_id" Aeson..= uid]) + +$(makeFieldLabelsNoPrefix ''ModifyUserData) +$(makeFieldLabelsNoPrefix ''GetCurrentUserGuildsOptions) diff --git a/Calamity/HTTP/Webhook.hs b/Calamity/HTTP/Webhook.hs new file mode 100644 --- /dev/null +++ b/Calamity/HTTP/Webhook.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Webhook endpoints +module Calamity.HTTP.Webhook ( + WebhookRequest (..), + CreateWebhookData (..), + ModifyWebhookData (..), + ExecuteWebhookOptions (..), +) where + +import Calamity.HTTP.Channel (AllowedMentions, CreateMessageAttachment (..)) +import Calamity.HTTP.Internal.Request +import Calamity.HTTP.Internal.Route +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Snowflake +import Data.Aeson qualified as Aeson +import Data.Default.Class +import Data.Text (Text) +import Data.Text qualified as T +import Network.HTTP.Client.MultipartFormData +import Network.HTTP.Req +import Network.Mime +import Optics + +data CreateWebhookData = CreateWebhookData + { name :: 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 + +instance CalamityToJSON' CreateWebhookData where + toPairs CreateWebhookData {..} = + [ "name" .?= name + , "avatar" .?= avatar + ] + +instance Default CreateWebhookData where + def = CreateWebhookData Nothing Nothing + +data ModifyWebhookData = ModifyWebhookData + { name :: 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) + deriving (Aeson.ToJSON) via CalamityToJSON ModifyWebhookData + +instance CalamityToJSON' ModifyWebhookData where + toPairs ModifyWebhookData {..} = + [ "name" .?= name + , "avatar" .?= avatar + , "channel_id" .?= channelID + ] + +instance Default ModifyWebhookData where + def = ModifyWebhookData Nothing Nothing Nothing + +data ExecuteWebhookOptions = ExecuteWebhookOptions + { wait :: Maybe Bool + , content :: Maybe Text + , attachments :: [CreateMessageAttachment] + , embeds :: Maybe [Embed] + , name :: Maybe Text + , avatarUrl :: Maybe Text + , allowedMentions :: Maybe AllowedMentions + , tts :: Maybe Bool + , components :: [Component] + } + deriving (Show) + +instance Default ExecuteWebhookOptions where + def = ExecuteWebhookOptions Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing [] + +data CreateMessageAttachmentJson = CreateMessageAttachmentJson + { id :: Int + , filename :: Text + , description :: Maybe Text + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON CreateMessageAttachmentJson + +instance CalamityToJSON' CreateMessageAttachmentJson where + toPairs CreateMessageAttachmentJson {..} = + [ "id" .= id + , "filename" .= filename + , "description" .?= description + ] + +data ExecuteWebhookJson = ExecuteWebhookJson + { content :: Maybe Text + , embeds :: Maybe [Embed] + , name :: Maybe Text + , avatarUrl :: Maybe Text + , tts :: Maybe Bool + , attachments :: [CreateMessageAttachmentJson] + , allowedMentions :: Maybe AllowedMentions + , components :: [Component] + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON ExecuteWebhookJson + +instance CalamityToJSON' ExecuteWebhookJson where + toPairs ExecuteWebhookJson {..} = + [ "content" .?= content + , "embeds" .?= embeds + , "avatar_url" .?= avatarUrl + , "tts" .?= tts + , "attachments" .= attachments + , "allowed_mentions" .?= allowedMentions + , "components" .= components + ] + +$(makeFieldLabelsNoPrefix ''CreateWebhookData) +$(makeFieldLabelsNoPrefix ''ModifyWebhookData) +$(makeFieldLabelsNoPrefix ''ExecuteWebhookOptions) + +data WebhookRequest a where + CreateWebhook :: (HasID Channel c) => c -> CreateWebhookData -> WebhookRequest Webhook + GetChannelWebhooks :: (HasID Channel c) => c -> WebhookRequest [Webhook] + GetGuildWebhooks :: (HasID Guild c) => c -> WebhookRequest [Webhook] + GetWebhook :: (HasID Webhook w) => w -> WebhookRequest Webhook + GetWebhookToken :: (HasID Webhook w) => w -> Text -> WebhookRequest Webhook + ModifyWebhook :: (HasID Webhook w) => w -> ModifyWebhookData -> WebhookRequest Webhook + ModifyWebhookToken :: (HasID Webhook w) => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook + DeleteWebhook :: (HasID Webhook w) => w -> WebhookRequest () + DeleteWebhookToken :: (HasID Webhook w) => w -> Text -> WebhookRequest () + ExecuteWebhook :: (HasID Webhook w) => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () + +baseRoute :: Snowflake Webhook -> RouteBuilder _ +baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id + +instance Request (WebhookRequest a) where + type Result (WebhookRequest a) = a + + route (CreateWebhook (getID @Channel -> cid) _) = + mkRouteBuilder + // S "channels" + // ID @Channel + // S "webhooks" + & giveID cid + & buildRoute + route (GetChannelWebhooks (getID @Channel -> cid)) = + mkRouteBuilder + // S "channels" + // ID @Channel + // S "webhooks" + & giveID cid + & buildRoute + route (GetGuildWebhooks (getID @Guild -> gid)) = + mkRouteBuilder + // S "guilds" + // ID @Guild + // S "webhooks" + & giveID gid + & buildRoute + route (GetWebhook (getID @Webhook -> wid)) = + baseRoute wid + & buildRoute + route (GetWebhookToken (getID @Webhook -> wid) t) = + baseRoute wid + // S t + & buildRoute + route (ModifyWebhook (getID @Webhook -> wid) _) = + baseRoute wid + & buildRoute + route (ModifyWebhookToken (getID @Webhook -> wid) t _) = + baseRoute wid + // S t + & buildRoute + route (DeleteWebhook (getID @Webhook -> wid)) = + baseRoute wid + & buildRoute + route (DeleteWebhookToken (getID @Webhook -> wid) t) = + baseRoute wid + // S t + & buildRoute + route (ExecuteWebhook (getID @Webhook -> wid) t _) = + baseRoute wid + // S t + & buildRoute + + action (CreateWebhook _ o) = postWith' $ ReqBodyJson o + action (GetChannelWebhooks _) = getWith + action (GetGuildWebhooks _) = getWith + action (GetWebhook _) = getWith + action (GetWebhookToken _ _) = getWith + action (ModifyWebhook _ o) = patchWith' $ ReqBodyJson o + action (ModifyWebhookToken _ _ o) = patchWith' $ ReqBodyJson o + action (DeleteWebhook _) = deleteWith + action (DeleteWebhookToken _ _) = deleteWith + action (ExecuteWebhook _ _ wh) = \u o -> do + let filePart CreateMessageAttachment {filename, content} n = + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) + { partFilename = Just (T.unpack filename) + , partContentType = Just (defaultMimeLookup filename) + } + attachmentPart CreateMessageAttachment {filename, description} n = + CreateMessageAttachmentJson n filename description + files = zipWith filePart (wh ^. #attachments) [(0 :: Int) ..] + attachments = zipWith attachmentPart (wh ^. #attachments) [0 ..] + jsonBody = + ExecuteWebhookJson + { content = wh ^. #content + , name = wh ^. #name + , avatarUrl = wh ^. #avatarUrl + , tts = wh ^. #tts + , embeds = wh ^. #embeds + , allowedMentions = wh ^. #allowedMentions + , components = wh ^. #components + , attachments = attachments + } + body <- reqBodyMultipart (partLBS "payload_json" (Aeson.encode jsonBody) : files) + postWithP' body ("wait" =:? (wh ^. #wait)) u o diff --git a/Calamity/Interactions.hs b/Calamity/Interactions.hs new file mode 100644 --- /dev/null +++ b/Calamity/Interactions.hs @@ -0,0 +1,64 @@ +-- | Calamity Interaction views +module Calamity.Interactions ( + module Calamity.Interactions.View, + module Calamity.Interactions.Utils, + module Calamity.Interactions.Eff, + + -- * Interactions and Views + -- $viewDocs +) where + +import Calamity.Interactions.Eff +import Calamity.Interactions.Utils +import Calamity.Interactions.View + +{- $viewDocs + + This module contains functions and types related to handling discord interactions. + + The data models for components can be found in "Calamity.Types.Model.Channel.Component" + + ==== Examples + + Displaying a 'View' + + @ + {\-# LANGUAGE ApplicativeDo #-\} + + let view = 'row' $ do + a <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "defer" + b <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "deferEph" + c <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "deferComp" + d <- 'button' 'Calamity.Types.Model.Channel.Component.ButtonPrimary' "modal" + pure (a, b, c, d) + + modalView = do + a <- 'textInput' 'Calamity.Types.Model.Channel.Component.TextInputShort' "a" + b <- 'textInput' 'Calamity.Types.Model.Channel.Component.TextInputParagraph' "b" + pure (a, b) + in 'runView' view ('Calamity.tell' ctx) $ \\(a, b, c, d) -> do + 'Control.Monad.when' a $ do + 'Control.Monad.void' 'defer' + 'Polysemy.embed' $ threadDelay 1000000 + 'Control.Monad.void' $ 'followUp' \@'Data.Text.Text' "lol" + + 'Control.Monad.when' b $ do + 'Control.Monad.void' 'deferEphemeral' + 'Polysemy.embed' $ threadDelay 1000000 + 'Control.Monad.void' $ 'followUpEphemeral' \@'Data.Text.Text' "lol" + + 'Control.Monad.when' c $ do + 'Control.Monad.void' 'deferComponent' + 'Polysemy.embed' $ threadDelay 1000000 + 'Control.Monad.void' $ 'followUp' \@'Data.Text.Text' "lol" + + 'Control.Monad.when' d $ do + 'Control.Monad.void' . 'Polysemy.Async.async' $ do + 'runView' modalView ('Control.Monad.void' . 'pushModal' "lol") $ \(a, b) -> do + 'Polysemy.embed' $ print (a, b) + 'Control.Monad.void' $ 'respond' ("Thanks: " <> a <> " " <> b) + 'endView' () + + pure () + @ +-} diff --git a/Calamity/Interactions/Eff.hs b/Calamity/Interactions/Eff.hs new file mode 100644 --- /dev/null +++ b/Calamity/Interactions/Eff.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Effect for working with an interaction +module Calamity.Interactions.Eff ( + InteractionEff (..), + getInteraction, + getInteractionID, + getApplicationID, + getInteractionToken, + getInteractionUser, +) where + +import Calamity.Types.Model.Interaction +import Calamity.Types.Model.User (User) +import Calamity.Types.Snowflake +import Control.Applicative ((<|>)) +import Data.Maybe (fromJust) +import Optics ((%), (^.), (^?), _Just) +import Polysemy +import Polysemy qualified as P + +data InteractionEff m a where + GetInteraction :: InteractionEff m Interaction + +makeSem ''InteractionEff + +getInteractionID :: (P.Member InteractionEff r) => P.Sem r (Snowflake Interaction) +getInteractionID = (^. #id) <$> getInteraction + +getApplicationID :: (P.Member InteractionEff r) => P.Sem r (Snowflake Application) +getApplicationID = (^. #applicationID) <$> getInteraction + +getInteractionToken :: (P.Member InteractionEff r) => P.Sem r InteractionToken +getInteractionToken = (^. #token) <$> getInteraction + +getInteractionUser :: (P.Member InteractionEff r) => P.Sem r (Snowflake User) +getInteractionUser = do + int <- getInteraction + let uid = int ^? #user % _Just % #id + mid = int ^? #member % _Just % #id + pure . fromJust $ uid <|> mid diff --git a/Calamity/Interactions/Utils.hs b/Calamity/Interactions/Utils.hs new file mode 100644 --- /dev/null +++ b/Calamity/Interactions/Utils.hs @@ -0,0 +1,207 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | Interaction related utilities +module Calamity.Interactions.Utils ( + respond, + respondEphemeral, + followUp, + followUpEphemeral, + edit, + defer, + deferEphemeral, + deferComponent, + pushModal, + userLocalState, +) where + +import Calamity.HTTP +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 Data.HashMap.Strict qualified as H +import Data.Text (Text) +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 + user invoking the interaction +-} +userLocalState :: + forall r s a. + (P.Member InteractionEff r) => + -- | Initial state + s -> + P.Sem (P.State s ': r) a -> + P.Sem r a +userLocalState s = + P.evalState H.empty + . P.reinterpret @(P.State s) @(P.State (H.HashMap (Snowflake User) s)) + ( \case + P.Get -> do + uid <- getInteractionUser + P.gets (H.lookupDefault s uid) + P.Put s -> do + uid <- getInteractionUser + P.modify' (H.insert uid s) + ) + +-- | Respond to an interaction with a globally visible message +respond :: + forall t r. + (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => + t -> + P.Sem r (Either RestError ()) +respond (runToMessage -> msg) = + let opts = + InteractionCallbackMessageOptions + { tts = msg ^. #tts + , content = msg ^. #content + , embeds = msg ^. #embeds + , allowedMentions = msg ^. #allowedMentions + , ephemeral = Just False + , suppressEmbeds = Just False + , components = msg ^. #components + , attachments = msg ^. #attachments + } + in do + interactionID <- getInteractionID + interactionToken <- getInteractionToken + invoke $ CreateResponseMessage interactionID interactionToken opts + +-- | Respond to an interaction with an ephemeral message +respondEphemeral :: + forall t r. + (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => + t -> + P.Sem r (Either RestError ()) +respondEphemeral (runToMessage -> msg) = + let opts = + InteractionCallbackMessageOptions + { tts = msg ^. #tts + , content = msg ^. #content + , embeds = msg ^. #embeds + , allowedMentions = msg ^. #allowedMentions + , ephemeral = Just True + , suppressEmbeds = Just False + , components = msg ^. #components + , attachments = msg ^. #attachments + } + in do + interactionID <- getInteractionID + interactionToken <- getInteractionToken + invoke $ CreateResponseMessage interactionID interactionToken opts + +-- | Respond to an interaction by editing the message that triggered the interaction +edit :: + forall t r. + (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => + t -> + P.Sem r (Either RestError ()) +edit (runToMessage -> msg) = + let opts = + InteractionCallbackMessageOptions + { tts = msg ^. #tts + , content = msg ^. #content + , embeds = msg ^. #embeds + , allowedMentions = msg ^. #allowedMentions + , ephemeral = Nothing + , suppressEmbeds = Nothing + , components = msg ^. #components + , attachments = msg ^. #attachments + } + in do + interactionID <- getInteractionID + interactionToken <- getInteractionToken + invoke $ CreateResponseUpdate interactionID interactionToken opts + +-- | Create a follow up response to an interaction +followUp :: + forall t r. + (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => + t -> + P.Sem r (Either RestError ()) +followUp (runToMessage -> msg) = + let opts = + InteractionCallbackMessageOptions + { tts = msg ^. #tts + , content = msg ^. #content + , embeds = msg ^. #embeds + , allowedMentions = msg ^. #allowedMentions + , ephemeral = Nothing + , suppressEmbeds = Nothing + , components = msg ^. #components + , attachments = msg ^. #attachments + } + in do + applicationID <- getApplicationID + interactionToken <- getInteractionToken + invoke $ CreateFollowupMessage applicationID interactionToken opts + +-- | Create an ephemeral follow up response to an interaction +followUpEphemeral :: + forall t r. + (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r, ToMessage t) => + t -> + P.Sem r (Either RestError ()) +followUpEphemeral (runToMessage -> msg) = + let opts = + InteractionCallbackMessageOptions + { tts = msg ^. #tts + , content = msg ^. #content + , embeds = msg ^. #embeds + , allowedMentions = msg ^. #allowedMentions + , ephemeral = Just True + , suppressEmbeds = Nothing + , components = msg ^. #components + , attachments = msg ^. #attachments + } + in do + applicationID <- getApplicationID + interactionToken <- getInteractionToken + invoke $ CreateFollowupMessage applicationID interactionToken opts + +-- | Defer an interaction and show a loading state, use @followUp@ later on +defer :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) +defer = do + interactionID <- getInteractionID + interactionToken <- getInteractionToken + invoke $ CreateResponseDefer interactionID interactionToken False + +{- | 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 + interactionToken <- getInteractionToken + invoke $ CreateResponseDefer interactionID interactionToken True + +-- | Defer operation +deferComponent :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => P.Sem r (Either RestError ()) +deferComponent = do + interactionID <- getInteractionID + interactionToken <- getInteractionToken + invoke $ CreateResponseDeferComponent interactionID interactionToken + +fixupActionRow :: Component -> Component +fixupActionRow r@(ActionRow' _) = r +fixupActionRow x = ActionRow' [x] + +{- | Push a modal as a response to an interaction + + You should probably use this with 'Calamity.Interaction.View.runView' +-} +pushModal :: (P.Members '[InteractionEff, RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => Text -> [Component] -> P.Sem r (Either RestError ()) +pushModal title c = do + -- we don't actually use the custom id of the modal. the custom ids of the + -- sub-components are enough to disambiguate + cid <- P.embed $ getStdRandom uniform + interactionID <- getInteractionID + interactionToken <- getInteractionToken + invoke . CreateResponseModal interactionID interactionToken $ InteractionCallbackModal cid title (map fixupActionRow c) diff --git a/Calamity/Interactions/View.hs b/Calamity/Interactions/View.hs new file mode 100644 --- /dev/null +++ b/Calamity/Interactions/View.hs @@ -0,0 +1,436 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Calamity.Interactions.View ( + ViewEff (..), + endView, + replaceView, + getSendResponse, + View, + row, + runView, + runViewInstance, + button, + button', + select, + select', + textInput, + textInput', + deleteInitialMsg, + instantiateView, +) where + +import Calamity.Client.Client (react) +import Calamity.Client.Types (BotC, EventType (InteractionEvt)) +import Calamity.HTTP.Channel (ChannelRequest (DeleteMessage)) +import Calamity.HTTP.Internal.Ratelimit (RatelimitEff) +import Calamity.HTTP.Internal.Request (invoke) +import Calamity.Interactions.Eff (InteractionEff (..)) +import Calamity.Metrics.Eff (MetricEff) +import Calamity.Types.LogEff (LogEff) +import Calamity.Types.Model.Channel.Component (CustomID) +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 Control.Concurrent.STM qualified as STM +import Control.Monad (guard, void) +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 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 + +data ViewComponent a = ViewComponent + { component :: C.Component + , parse :: Interaction -> ExtractResult a + } + +instance Functor ViewComponent where + fmap f ViewComponent {component, parse} = ViewComponent {component, parse = fmap f . parse} + +{- | A view containing one or more components + + This has an applicative interface to allow for easy composition of + components. +-} +data View a + = NilView a + | SingView (forall g. (RandomGen g) => g -> (ViewComponent a, g)) + | RowView (View a) + | forall x. MultView (View (x -> a)) (View x) + +{- | Convert a 'View' such that it renders as a row. + + Note: nested rows are not allowed by discord, along with further restrictions + listed here: + https://discord.com/developers/docs/interactions/message-components +-} +row :: View a -> View a +row = RowView + +instance Functor View where + fmap f (NilView x) = NilView (f x) + fmap f (SingView x) = SingView (\r -> let (x', r') = x r in (f <$> x', r')) + fmap f (RowView x) = RowView (fmap f x) + fmap f (MultView x y) = MultView (fmap (f .) x) y + +instance Applicative View where + pure = NilView + (<*>) = MultView + +type MonadViewMessage = + 'E.ShowType View + 'E.:<>: 'E.Text " doesn't have a Monad instance as we need to be able to inspect the contained components" + 'E.:$$: 'E.Text "If you haven't already, enable ApplicativeDo" + 'E.:$$: 'E.Text "Also, make sure you use lazy patterns: ~(a, b) instead of (a, b)" + 'E.:$$: 'E.Text "Refer to https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/applicative_do.html" + +instance (E.TypeError MonadViewMessage) => Monad View where + (>>=) = undefined -- unreachable + +data ExtractOkType + = -- | At least one value has been extracted + SomeExtracted + | -- | No values have been extracted, we shouldn't trigger the callback + NoneExtracted + deriving (Show) + +instance Semigroup ExtractOkType where + SomeExtracted <> _ = SomeExtracted + _ <> SomeExtracted = SomeExtracted + _ <> _ = NoneExtracted + +data ExtractResult a + = -- | Extraction succeeded in some way + ExtractOk ExtractOkType a + | -- | Bail out from parsing this interaction for the current view + ExtractFail + deriving (Show, Functor) + +instance Applicative ExtractResult where + pure = ExtractOk SomeExtracted + + ExtractOk ta f <*> ExtractOk tb x = ExtractOk (ta <> tb) $ f x + _ <*> _ = ExtractFail + +data ViewInstance a = ViewInstance + { -- customIDS :: Set C.CustomID , + extract :: Interaction -> ExtractResult a + , rendered :: [C.Component] + } + +data ViewEff ret inp sendResp m a where + -- | Mark the view as finished and set the return value. + -- + -- This doesn't trigger the immediate exit from the code it is used in, the + -- view will exit before it would wait for the next event. + EndView :: ret -> ViewEff ret inp sendResp m () + -- | Given a view and a way to display the rendered view to discord, show the + -- view and start tracking the new view + -- + -- This works for both message components and modals + ReplaceView :: View inp -> ([C.Component] -> m ()) -> ViewEff ret inp sendResp m () + -- | Get the result of the action that sent a value + GetSendResponse :: ViewEff ret inp sendResp m sendResp + +P.makeSem ''ViewEff + +extractCustomID :: Interaction -> Maybe CustomID +extractCustomID Interaction {data_, type_} = do + guard $ type_ == MessageComponentType + data' <- data_ + data' ^. #customID + +guardComponentType :: Interaction -> C.ComponentType -> Maybe () +guardComponentType Interaction {data_} expected = do + data' <- data_ + guard $ data' ^. #componentType == Just expected + +extractOkFromMaybe :: Maybe a -> ExtractResult (Maybe a) +extractOkFromMaybe (Just a) = ExtractOk SomeExtracted (Just a) +extractOkFromMaybe Nothing = ExtractOk NoneExtracted Nothing + +extractOkFromBool :: Bool -> ExtractResult Bool +extractOkFromBool True = ExtractOk SomeExtracted True +extractOkFromBool False = ExtractOk NoneExtracted False + +{- | Construct a 'View' containing a 'C.Button' with the given style and label + + Other fields of 'C.Button' default to 'Nothing' +-} +button :: C.ButtonStyle -> Text -> View Bool +button s l = button' ((#style .~ s) . (#label ?~ l)) + +{- | Construct a 'View' containing a 'C.Button', then modify the component with + the passed mapping function + + The 'C.Button' passed to the mapping function will have a style of + 'C.ButtonPrimary', other fields will be 'Nothing' +-} +button' :: (C.Button -> C.Button) -> View Bool +button' f = SingView $ \g -> + let (cid, g') = uniform g + comp = C.Button' . f $ C.button C.ButtonPrimary cid + parse' int = + Just True + == ( do + customID <- extractCustomID int + guardComponentType int C.ButtonType + pure $ customID == cid + ) + parse = extractOkFromBool . parse' + in (ViewComponent comp parse, g') + +{- | Construct a 'View' containing a 'C.Select' with the given list of values + + Each element of the passed options list is used as both the display + 'C.SelectOption.label' and 'C.SelectOption.value', use 'select'' if you + desire more control +-} +select :: [Text] -> View (Maybe Text) +select opts = ensureOne <$> select' (map (\x -> C.sopt x x) opts) Prelude.id + where + ensureOne :: Maybe [Text] -> Maybe Text + ensureOne mx = do + o <- mx + guard $ length o == 1 + case o of + [x] -> Just x + _ -> Nothing + +{- | Construct a 'View' containing a 'C.Select' with the given options, then + modify the component with the passed mapping function +-} +select' :: [C.SelectOption] -> (C.Select -> C.Select) -> View (Maybe [Text]) +select' opts f = SingView $ \g -> + let (cid, g') = uniform g + comp = f $ C.select opts cid + finalValues = S.fromList $ comp ^.. #options % traversed % #value + parse int = extractOkFromMaybe $ do + customID <- extractCustomID int + guard $ customID == cid + guardComponentType int C.SelectType + values <- int ^? #data_ % _Just % #values % _Just + let values' = S.fromList values + guard $ S.isSubsetOf values' finalValues + pure values + in (ViewComponent (C.Select' comp) parse, g') + +data TextInputDecoded = TextInputDecoded + { value :: Maybe Text + , customID :: CustomID + } + deriving (Show) + +$(makeFieldLabelsNoPrefix ''TextInputDecoded) + +instance Aeson.FromJSON TextInputDecoded where + parseJSON = Aeson.withObject "TextInputDecoded" $ \v -> + TextInputDecoded + <$> v .:? "value" + <*> v .: "custom_id" + +parseTextInput :: CustomID -> Interaction -> ExtractResult (Maybe Text) +parseTextInput cid int = extractOkFromMaybe $ do + components <- int ^? #data_ % _Just % #components + -- currently, each text input is a singleton actionrow containing a single textinput component + + let textInputs = components ^.. traversed % traversed % key "components" % _Array % traversed + inputs' :: Aeson.Result [TextInputDecoded] = traverse Aeson.fromJSON textInputs + + inputs <- case inputs' of + Aeson.Success x -> pure x + Aeson.Error _ -> Nothing + + thisValue <- Data.List.find ((== cid) . (^. #customID)) inputs + + thisValue ^. #value + +{- | Construct a 'View' containing a 'C.TextInput' with the given style and label + + All other fields of 'C.TextInput' default to 'Nothing' + + This view ensures that a value was passed for an input +-} +textInput :: + C.TextInputStyle -> + -- | Label + Text -> + View Text +textInput s l = SingView $ \g -> + let (cid, g') = uniform g + comp = C.TextInput' $ C.textInput s l cid + parse = ensure <$> parseTextInput cid + in (ViewComponent comp parse, g') + where + ensure (ExtractOk v (Just x)) = ExtractOk v x + ensure _ = ExtractFail + +{- | Construct a 'View' containing a 'C.TextInput' with the given style and label, + then modify the component with the passed mapping function +-} +textInput' :: + C.TextInputStyle -> + -- | Label + Text -> + (C.TextInput -> C.TextInput) -> + View (Maybe Text) +textInput' s l f = SingView $ \g -> + let (cid, g') = uniform g + comp = C.TextInput' . f $ C.textInput s l cid + parse = parseTextInput cid + in (ViewComponent comp parse, g') + +-- componentIDS :: C.Component -> S.Set CustomID +-- componentIDS (C.ActionRow' coms) = S.unions $ map componentIDS coms +-- componentIDS (C.Button' C.Button {customID}) = S.singleton customID +-- componentIDS (C.LinkButton' _) = S.empty +-- componentIDS (C.Select' C.Select {customID}) = S.singleton customID +-- componentIDS (C.TextInput' C.TextInput {customID}) = S.singleton customID + +-- | Generate a 'ViewInstance' of a 'View' by filling in 'CustomID's with random values +instantiateView :: (RandomGen g) => g -> View a -> (ViewInstance a, g) +instantiateView g v = + case v of + NilView x -> (ViewInstance (const $ ExtractOk SomeExtracted x) [], g) + SingView f -> + let (ViewComponent c p, g') = f g + i = ViewInstance p [c] + in (i, g') + RowView x -> + let (v'@ViewInstance {rendered}, g') = instantiateView g x + in (v' {rendered = [C.ActionRow' rendered]}, g') + MultView a b -> + let (ViewInstance ia ra, g') = instantiateView g a + (ViewInstance ib rb, g'') = instantiateView g' b + inv i = ia i <*> ib i + in (ViewInstance inv (ra <> rb), g'') + +-- | Delete the initial message containing components +deleteInitialMsg :: (BotC r, P.Member (ViewEff a inp (Either e Message)) r) => P.Sem r () +deleteInitialMsg = do + ini <- getSendResponse + case ini of + Right m -> + 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. +-} +runView :: + (BotC r) => + -- | The initial view to render + View inp -> + -- | A function to send the rendered view (i.e. as a message or a modal) + ([C.Component] -> P.Sem r sendResp) -> + -- | Your callback effect. + -- + -- local state semantics are preserved between calls here, you can keep state around + (inp -> P.Sem (InteractionEff ': ViewEff a inp sendResp ': r) ()) -> + P.Sem r a +runView v sendRendered m = do + inst@ViewInstance {rendered} <- getStdRandom (`instantiateView` v) + r <- sendRendered rendered + runViewInstance r inst m + +{- | Run a prerendered 'View', returning the value passed to 'endView' + + This function won't send the view, you should do that yourself +-} +runViewInstance :: + (BotC r) => + -- | An initial value to act as the value of @GetSendResponse@ + -- + -- If you just sent a message, probably pass that + sendResp -> + -- | The initial view to run + ViewInstance inp -> + -- | Your callback effect. + -- + -- In here you get access to the 'InteractionEff' and 'ViewEff' effects. + -- + -- local state semantics are preserved between calls here, you can keep state around + (inp -> P.Sem (InteractionEff ': ViewEff a inp sendResp ': r) ()) -> + P.Sem r a +runViewInstance initSendResp inst m = P.resourceToIOFinal $ do + eventIn <- P.embed STM.newTQueueIO + + P.bracket + (P.raise $ react @'InteractionEvt (P.embed . sender eventIn)) + P.raise + ( \_ -> do + P.raise $ innerLoop initSendResp inst eventIn m + ) + where + interpretInteraction :: + forall r. + Interaction -> + P.Sem (InteractionEff ': r) () -> + P.Sem r () + interpretInteraction int = + P.interpret + ( \case + GetInteraction -> pure int + ) + + interpretView :: + forall r ret inp sendResp. + (P.Member (P.Embed IO) r) => + P.Sem (ViewEff ret inp sendResp ': r) () -> + P.Sem (P.State (Maybe ret, ViewInstance inp, sendResp) ': r) () + interpretView = + P.reinterpretH + ( \case + EndView x -> P.modify' (_1 ?~ x) >>= P.pureT + ReplaceView v m -> do + inst@ViewInstance {rendered} <- P.embed $ getStdRandom (`instantiateView` v) + P.modify' (_2 .~ inst) + P.runTSimple $ m rendered + GetSendResponse -> P.gets (^. _3) >>= P.pureT + ) + + innerLoop :: + forall r ret inp sendResp. + (P.Members '[RatelimitEff, TokenEff, LogEff, MetricEff, P.Embed IO] r) => + sendResp -> + ViewInstance inp -> + STM.TQueue Interaction -> + (inp -> P.Sem (InteractionEff ': ViewEff ret inp sendResp ': r) ()) -> + P.Sem r ret + innerLoop initialSendResp initialInst inChan m = P.evalState (Nothing, initialInst, initialSendResp) innerLoop' + where + innerLoop' :: P.Sem (P.State (Maybe ret, ViewInstance inp, sendResp) ': r) ret + innerLoop' = do + (s, ViewInstance {extract}, _) <- P.get + case s of + Just x -> pure x + Nothing -> do + int <- P.embed $ STM.atomically (STM.readTQueue inChan) + case extract int of + ExtractOk SomeExtracted x -> interpretView $ interpretInteraction int (m x) + _ -> pure () + + -- if Just True == ((`S.member` customIDS) <$> extractCustomID int) + -- then case extract int of + -- ExtractOk SomeExtracted x -> interpretView $ interpretInteraction int (m x) + -- _ -> pure () + -- else pure () + innerLoop' + + sender :: STM.TQueue Interaction -> Interaction -> IO () + sender eventIn int = STM.atomically $ STM.writeTQueue eventIn int diff --git a/Calamity/Internal/BoundedStore.hs b/Calamity/Internal/BoundedStore.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/BoundedStore.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | A thing for storing the last N things with IDs +module Calamity.Internal.BoundedStore ( + BoundedStore, + empty, + addItem, + getItem, + dropItem, +) where + +import Calamity.Internal.Utils (unlessM, whenM) +import Calamity.Types.Snowflake (HasID (getID), HasID', Snowflake) +import Control.Monad (when) +import Control.Monad.State.Lazy (execState) +import Data.Default.Class (Default (..)) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as H +import Deque.Lazy (Deque) +import Deque.Lazy qualified as DQ +import Optics +import Optics.State.Operators ((%=), (.=)) + +data BoundedStore a = BoundedStore + { itemQueue :: Deque (Snowflake a) + , items :: HashMap (Snowflake a) a + , limit :: Int + , size :: Int + } + deriving (Show) + +$(makeFieldLabelsNoPrefix ''BoundedStore) + +instance Foldable BoundedStore where + foldr f i = foldr f i . H.elems . items + +instance Default (BoundedStore a) where + def = BoundedStore mempty mempty 1000 0 + +empty :: Int -> BoundedStore a +empty limit = BoundedStore mempty mempty limit 0 + +type instance Index (BoundedStore a) = Snowflake a + +type instance IxValue (BoundedStore a) = a + +instance (HasID' a) => Ixed (BoundedStore a) + +instance (HasID' a) => At (BoundedStore a) where + at k = lensVL $ \f m -> + let mv = getItem k m + in f mv <&> \case + Nothing -> maybe m (const (dropItem k m)) mv + Just v -> addItem v m + {-# INLINE at #-} + +addItem :: (HasID' a) => a -> BoundedStore a -> BoundedStore a +addItem m = execState $ do + unlessM (H.member (getID m) <$> use #items) $ do + #itemQueue %= DQ.cons (getID m) + #size %= succ + + size <- use #size + limit <- use #limit + + when (size > limit) $ do + q <- use #itemQueue + let Just (rid, q') = DQ.unsnoc q + #itemQueue .= q' + #items %= sans rid + #size %= pred + + #items %= H.insert (getID m) m +{-# INLINE addItem #-} + +getItem :: Snowflake a -> BoundedStore a -> Maybe a +getItem id s = H.lookup id (s ^. #items) +{-# INLINE getItem #-} + +dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a +dropItem id = execState $ do + whenM (H.member id <$> use #items) $ do + #size %= pred + + #itemQueue %= DQ.filter (/= id) + #items %= H.delete id +{-# INLINE dropItem #-} diff --git a/Calamity/Internal/ConstructorName.hs b/Calamity/Internal/ConstructorName.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/ConstructorName.hs @@ -0,0 +1,25 @@ +-- | Get the constructor name of something +module Calamity.Internal.ConstructorName ( + CtorName (..), + GCtorName (..), +) where + +import GHC.Generics + +class GCtorName f where + gctorName :: f a -> String + +instance (Constructor c) => GCtorName (C1 c f) where + gctorName = conName + +instance (GCtorName f) => GCtorName (D1 d f) where + gctorName (M1 a) = gctorName a + +instance (GCtorName f, GCtorName g) => GCtorName (f :+: g) where + gctorName (L1 a) = gctorName a + gctorName (R1 a) = gctorName a + +class CtorName a where + ctorName :: a -> String + default ctorName :: (Generic a, GCtorName (Rep a)) => a -> String + ctorName = gctorName . from diff --git a/Calamity/Internal/IntColour.hs b/Calamity/Internal/IntColour.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/IntColour.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket due to operator fixities" #-} + +-- | An internal newtype for parsing colours +module Calamity.Internal.IntColour ( + IntColour (..), + colourToWord64, + colourFromWord64, +) where + +import Data.Aeson +import Data.Bits +import Data.Colour +import Data.Colour.SRGB (RGB (RGB), sRGB24, toSRGB24) +import Data.Word (Word64) +import TextShow + +newtype IntColour = IntColour + { fromIntColour :: Colour Double + } + deriving (Show) via Colour Double + deriving (TextShow) via FromStringShow (Colour Double) + +colourToWord64 :: IntColour -> Word64 +colourToWord64 (IntColour c) = + let RGB r g b = toSRGB24 c + i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b + in i + +colourFromWord64 :: Word64 -> IntColour +colourFromWord64 i = + let r = (i `shiftR` 16) .&. 0xff + g = (i `shiftR` 8) .&. 0xff + b = i .&. 0xff + in IntColour $ sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b) + +instance ToJSON IntColour where + toJSON = toJSON . colourToWord64 + +instance FromJSON IntColour where + parseJSON v = colourFromWord64 <$> parseJSON v diff --git a/Calamity/Internal/LocalWriter.hs b/Calamity/Internal/LocalWriter.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/LocalWriter.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A Writer monad that supports local writing, reverse reader I guess? +module Calamity.Internal.LocalWriter ( + LocalWriter (..), + ltell, + llisten, + runLocalWriter, +) where + +import Polysemy qualified as P +import Polysemy.State qualified as P + +data LocalWriter o m a where + Ltell :: o -> LocalWriter o m () + Llisten :: m a -> LocalWriter o m (o, a) + +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 + ) diff --git a/Calamity/Internal/RunIntoIO.hs b/Calamity/Internal/RunIntoIO.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/RunIntoIO.hs @@ -0,0 +1,23 @@ +-- | Something for converting polysemy actions into IO actions +module Calamity.Internal.RunIntoIO ( + runSemToIO, + bindSemToIO, +) where + +import Data.Functor + +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 + m' <- P.runS m + ins <- P.getInspectorS + P.liftS $ pure (P.inspect ins <$> m') + +bindSemToIO :: forall r p a. (P.Member (P.Final IO) r) => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a)) +bindSemToIO m = P.withStrategicToFinal $ do + istate <- P.getInitialStateS + m' <- P.bindS m + ins <- P.getInspectorS + P.liftS $ pure (\x -> P.inspect ins <$> m' (istate $> x)) diff --git a/Calamity/Internal/SnowflakeMap.hs b/Calamity/Internal/SnowflakeMap.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/SnowflakeMap.hs @@ -0,0 +1,232 @@ +-- | Module for custom instance of Data.HashMap.Strict that decodes from any list of objects that have an id field +module Calamity.Internal.SnowflakeMap where + +import Calamity.Internal.Utils () +import Calamity.Types.Snowflake +import Data.Aeson (FromJSON (..), ToJSON (..), withArray) +import Data.Data +import Data.Foldable qualified as F +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as SH +import Data.Hashable +import GHC.Exts (IsList) +import Optics +import TextShow +import Unsafe.Coerce + +newtype SnowflakeMap a = SnowflakeMap + { unSnowflakeMap :: HashMap (Snowflake a) a + } + deriving stock (Eq, Data, Ord, Show) + deriving (TextShow) via FromStringShow (SnowflakeMap a) + deriving newtype (IsList, Semigroup, Monoid) + deriving newtype (Hashable) + +-- instance At (SnowflakeMap a) where +-- at k f m = at (unSnowflakeMap k) f m + +instance Functor SnowflakeMap where + fmap f = SnowflakeMap . coerceSnowflakeMap . fmap f . unSnowflakeMap + +instance Foldable SnowflakeMap where + foldr f b = Prelude.foldr f b . unSnowflakeMap + +instance Traversable SnowflakeMap where + traverse f = fmap (SnowflakeMap . coerceSnowflakeMap) . traverse f . unSnowflakeMap + +type instance Index (SnowflakeMap a) = Snowflake a + +type instance IxValue (SnowflakeMap a) = a + +_SnowflakeMap :: + ( Iso + (SnowflakeMap a) + (SnowflakeMap a1) + (HashMap (Snowflake a) a) + (HashMap (Snowflake a1) a1) + ) +_SnowflakeMap = iso unSnowflakeMap SnowflakeMap + +instance Ixed (SnowflakeMap a) where + ix i = _SnowflakeMap % ix i + {-# INLINE ix #-} + +instance At (SnowflakeMap a) where + at i = _SnowflakeMap % at i + {-# INLINE at #-} + +overSM :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b +overSM f = SnowflakeMap . f . unSnowflakeMap +{-# INLINEABLE overSM #-} + +-- SAFETY: 'Snowflake' always uses the underlying hash function (Word64) +coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v +coerceSnowflakeMap = unsafeCoerce +{-# INLINEABLE coerceSnowflakeMap #-} + +empty :: SnowflakeMap a +empty = SnowflakeMap SH.empty +{-# INLINEABLE empty #-} + +singleton :: (HasID' a) => a -> SnowflakeMap a +singleton v = SnowflakeMap $ SH.singleton (getID v) v +{-# INLINEABLE singleton #-} + +null :: SnowflakeMap a -> Bool +null = SH.null . unSnowflakeMap +{-# INLINEABLE null #-} + +size :: SnowflakeMap a -> Int +size = SH.size . unSnowflakeMap +{-# INLINEABLE size #-} + +member :: Snowflake a -> SnowflakeMap a -> Bool +member k = SH.member k . unSnowflakeMap +{-# INLINEABLE member #-} + +lookup :: Snowflake a -> SnowflakeMap a -> Maybe a +lookup k = SH.lookup k . unSnowflakeMap +{-# INLINEABLE lookup #-} + +lookupDefault :: a -> Snowflake a -> SnowflakeMap a -> a +lookupDefault d k = SH.lookupDefault d k . unSnowflakeMap +{-# INLINEABLE lookupDefault #-} + +(!) :: SnowflakeMap a -> Snowflake a -> a +(!) m k = unSnowflakeMap m SH.! k +{-# INLINEABLE (!) #-} + +infixl 9 ! + +insert :: (HasID' a) => a -> SnowflakeMap a -> SnowflakeMap a +insert v = overSM $ SH.insert (getID v) v +{-# INLINEABLE insert #-} + +insertWith :: (HasID' a) => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a +insertWith f v = overSM $ SH.insertWith f (getID v) v +{-# INLINEABLE insertWith #-} + +delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a +delete k = overSM $ SH.delete k +{-# INLINEABLE delete #-} + +adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a +adjust f k = overSM $ SH.adjust f k +{-# INLINEABLE adjust #-} + +update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a +update f k = overSM $ SH.update f k +{-# INLINEABLE update #-} + +alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a +alter f k = overSM $ SH.alter f k +{-# INLINEABLE alter #-} + +union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a +union m m' = SnowflakeMap $ SH.union (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE union #-} + +unionWith :: (a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a +unionWith f m m' = SnowflakeMap $ SH.unionWith f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE unionWith #-} + +unionWithKey :: (Snowflake a -> a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a +unionWithKey f m m' = SnowflakeMap $ SH.unionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE unionWithKey #-} + +unions :: [SnowflakeMap a] -> SnowflakeMap a +unions = SnowflakeMap . SH.unions . Prelude.map unSnowflakeMap +{-# INLINEABLE unions #-} + +map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 +map f = overSM $ coerceSnowflakeMap . SH.map f +{-# INLINEABLE map #-} + +mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 +mapWithKey f = overSM $ coerceSnowflakeMap . SH.mapWithKey f +{-# INLINEABLE mapWithKey #-} + +traverseWithKey :: (Applicative f) => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) +traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . SH.traverseWithKey f . unSnowflakeMap +{-# INLINEABLE traverseWithKey #-} + +difference :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a +difference m m' = SnowflakeMap $ SH.difference (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE difference #-} + +differenceWith :: (a -> a -> Maybe a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a +differenceWith f m m' = SnowflakeMap $ SH.differenceWith f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE differenceWith #-} + +intersection :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a +intersection m m' = SnowflakeMap $ SH.intersection (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE intersection #-} + +intersectionWith :: (a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b +intersectionWith f m m' = SnowflakeMap . coerceSnowflakeMap $ SH.intersectionWith f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE intersectionWith #-} + +intersectionWithKey :: (Snowflake a -> a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b +intersectionWithKey f m m' = SnowflakeMap . coerceSnowflakeMap $ SH.intersectionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE intersectionWithKey #-} + +foldl' :: (a -> b -> a) -> a -> SnowflakeMap b -> a +foldl' f s m = SH.foldl' f s $ unSnowflakeMap m +{-# INLINEABLE foldl' #-} + +foldlWithKey' :: (a -> Snowflake b -> b -> a) -> a -> SnowflakeMap b -> a +foldlWithKey' f s m = SH.foldlWithKey' f s $ unSnowflakeMap m +{-# INLINEABLE foldlWithKey' #-} + +foldr :: (b -> a -> a) -> a -> SnowflakeMap b -> a +foldr f s m = SH.foldr f s $ unSnowflakeMap m +{-# INLINEABLE foldr #-} + +foldrWithKey :: (Snowflake b -> b -> a -> a) -> a -> SnowflakeMap b -> a +foldrWithKey f s m = SH.foldrWithKey f s $ unSnowflakeMap m +{-# INLINEABLE foldrWithKey #-} + +filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a +filter f = overSM $ SH.filter f +{-# INLINEABLE filter #-} + +filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a +filterWithKey f = overSM $ SH.filterWithKey f +{-# INLINEABLE filterWithKey #-} + +mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b +mapMaybe f = overSM $ coerceSnowflakeMap . SH.mapMaybe f +{-# INLINEABLE mapMaybe #-} + +mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b +mapMaybeWithKey f = overSM $ coerceSnowflakeMap . SH.mapMaybeWithKey f +{-# INLINEABLE mapMaybeWithKey #-} + +keys :: SnowflakeMap a -> [Snowflake a] +keys = SH.keys . unSnowflakeMap +{-# INLINEABLE keys #-} + +elems :: SnowflakeMap a -> [a] +elems = SH.elems . unSnowflakeMap +{-# INLINEABLE elems #-} + +toList :: SnowflakeMap a -> [(Snowflake a, a)] +toList = SH.toList . unSnowflakeMap +{-# INLINEABLE toList #-} + +fromList :: (HasID' a) => [a] -> SnowflakeMap a +fromList = SnowflakeMap . SH.fromList . Prelude.map (\v -> (getID v, v)) +{-# INLINEABLE fromList #-} + +fromListWith :: (HasID' a) => (a -> a -> a) -> [a] -> SnowflakeMap a +fromListWith f = SnowflakeMap . SH.fromListWith f . Prelude.map (\v -> (getID v, v)) +{-# INLINEABLE fromListWith #-} + +instance (FromJSON a, HasID' a) => FromJSON (SnowflakeMap a) where + parseJSON = withArray "SnowflakeMap" $ \l -> do + parsed <- traverse parseJSON l + pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed + +instance (ToJSON a) => ToJSON (SnowflakeMap a) where + toJSON = toJSON . elems + toEncoding = toEncoding . elems diff --git a/Calamity/Internal/UnixTimestamp.hs b/Calamity/Internal/UnixTimestamp.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/UnixTimestamp.hs @@ -0,0 +1,60 @@ +-- | Internal newtype for deserializing timestamps +module Calamity.Internal.UnixTimestamp ( + UnixTimestamp (..), + unixToMilliseconds, + millisecondsToUnix, +) where + +import Calamity.Internal.Utils () +import Control.Arrow +import Data.Aeson +import Data.Aeson.Encoding (word64) +import Data.Time +import Data.Time.Clock.POSIX +import Data.Word +import TextShow + +newtype UnixTimestamp = UnixTimestamp + { unUnixTimestamp :: UTCTime + } + deriving (Show) via UTCTime + deriving (TextShow) via FromStringShow UTCTime + +unixToMilliseconds :: UnixTimestamp -> Word64 +unixToMilliseconds = + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> (* 1000) + >>> round + +millisecondsToUnix :: Word64 -> UnixTimestamp +millisecondsToUnix = + toRational + >>> fromRational + >>> (/ 1000) + >>> posixSecondsToUTCTime + >>> UnixTimestamp + +instance ToJSON UnixTimestamp where + 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 diff --git a/Calamity/Internal/Updateable.hs b/Calamity/Internal/Updateable.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/Updateable.hs @@ -0,0 +1,145 @@ +-- | Updateable objects +module Calamity.Internal.Updateable (Updateable (..)) where + +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.UpdatedMessage +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Data.Maybe +import GHC.TypeLits +import Optics + +class Updateable a where + type Updated a + type Updated a = a + + update :: Updated a -> a -> a + +-- | sets original field to new field +setF :: + forall (f :: Symbol) o n b k. + ( k ~ A_Lens + , LabelOptic' f k o b + , LabelOptic' f k n b + ) => + n -> + o -> + o +setF n = labelOptic @f .~ n ^. labelOptic @f + +-- | sets original field to unwrapped new field if new field is not Nothing +mergeF :: + forall (f :: Symbol) o n b k. + ( k ~ A_Lens + , LabelOptic' f k o b + , LabelOptic' f k n (Maybe b) + ) => + n -> + o -> + o +mergeF n = labelOptic @f %~ \oldv -> fromMaybe oldv (n ^. labelOptic @f) + +-- | sets original field to new field if new field is not nothing +mergeF' :: + forall (f :: Symbol) old new v k. + ( k ~ A_Lens + , LabelOptic' f k old (Maybe v) + , LabelOptic' f k new (Maybe v) + ) => + new -> + old -> + old +mergeF' new = labelOptic @f %~ \oldv -> lastMaybe oldv (new ^. labelOptic @f) + +-- | sets original field to new field if new field was present +updateNullableDest :: + forall (f :: Symbol) old new v k. + ( k ~ A_Lens + , LabelOptic' f k old (Maybe v) + , LabelOptic' f k new (Maybe (MaybeNull v)) + ) => + new -> + old -> + old +updateNullableDest new = case new ^. labelOptic @f of + Just (NotNull x) -> labelOptic @f ?~ x + Just WasNull -> labelOptic @f .~ Nothing + Nothing -> Prelude.id + +-- NOTE: afaik only messages get partial updates +instance Updateable Message where + type Updated Message = UpdatedMessage + + update n o = + o + & mergeF @"content" n + & updateNullableDest @"editedTimestamp" n + & mergeF @"tts" n + & mergeF @"mentionEveryone" n + & mergeF @"mentions" n + & mergeF @"mentionRoles" n + & mergeF @"mentionChannels" n + & mergeF @"attachments" n + & mergeF @"embeds" n + & mergeF @"reactions" n + & mergeF @"pinned" n + & mergeF @"type_" n + & updateNullableDest @"activity" n + & updateNullableDest @"application" n + & updateNullableDest @"messageReference" n + & mergeF @"flags" n + & updateNullableDest @"referencedMessage" n + & updateNullableDest @"interaction" n + & mergeF @"components" n + +instance Updateable Channel where + update n _ = n + +instance Updateable DMChannel where + update n _ = n + +instance Updateable GuildChannel where + update n _ = n + +instance Updateable Guild where + type Updated Guild = UpdatedGuild + + update n o = + o + & setF @"name" n + & setF @"icon" n + & setF @"splash" n + & setF @"discoverySplash" n + & setF @"banner" n + & setF @"owner" n + & setF @"ownerID" n + & mergeF @"permissions" n + & setF @"afkChannelID" n + & setF @"afkTimeout" n + & mergeF @"embedEnabled" n + & setF @"embedChannelID" n + & setF @"verificationLevel" n + & setF @"defaultMessageNotifications" n + & setF @"explicitContentFilter" n + & setF @"roles" n + & setF @"features" n + & setF @"mfaLevel" n + & setF @"applicationID" n + & mergeF @"widgetEnabled" n + & setF @"widgetChannelID" n + & setF @"systemChannelID" n + & setF @"preferredLocale" n + +instance Updateable User where + update n o = + o + & setF @"username" n + & setF @"discriminator" n + & mergeF' @"bot" n + & setF @"avatar" n + & mergeF' @"mfaEnabled" n + & mergeF' @"verified" n + & mergeF' @"email" n + & mergeF' @"flags" n + & mergeF' @"premiumType" n diff --git a/Calamity/Internal/Utils.hs b/Calamity/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/Calamity/Internal/Utils.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | Internal utilities and instances +module Calamity.Internal.Utils ( + whileMFinalIO, + untilJustFinalIO, + whenJust, + whenM, + unlessM, + lastMaybe, + leftToMaybe, + rightToMaybe, + justToEither, + (<<$>>), + (<<*>>), + (<.>), + (.?=), + (.=), + debug, + info, + Calamity.Internal.Utils.error, + swap, + DefaultingMap (..), + AesonVector (..), + CalamityFromStringShow (..), + MaybeNull (..), + CalamityToJSON (..), + CalamityToJSON' (..), +) where + +import Calamity.Internal.RunIntoIO +import Calamity.Types.LogEff +import Control.Applicative +import Data.Aeson qualified as Aeson +import Data.Aeson.Encoding (null_) +import Data.Default.Class +import Data.Map qualified as M +import Data.Maybe (catMaybes) +import Data.Semigroup (Last (..)) +import Data.Text +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 + + This means Polysemy.Error won't work to break the loop, etc. + Instead, Error/Alternative will just result in the loop quitting. +-} +whileMFinalIO :: (P.Member (P.Final IO) r) => P.Sem r Bool -> P.Sem r () +whileMFinalIO action = do + action' <- runSemToIO action + P.embedFinal $ go action' + where + go action' = do + r <- action' + case r of + Just True -> + go action' + _ -> + pure () + +{- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks + + This means Polysemy.Error won't work to break the loop, etc. + Instead, Error/Alternative will just result in another loop. +-} +untilJustFinalIO :: (P.Member (P.Final IO) r) => P.Sem r (Maybe a) -> P.Sem r a +untilJustFinalIO action = do + action' <- runSemToIO action + P.embedFinal $ go action' + where + go action' = do + r <- action' + case r of + Just (Just a) -> + pure a + _ -> + go action' + +whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m () +whenJust = flip $ maybe (pure ()) + +whenM :: (Monad m) => m Bool -> m () -> m () +whenM p m = + p >>= \case + True -> m + False -> pure () + +unlessM :: (Monad m) => m Bool -> m () -> m () +unlessM = whenM . (not <$>) + +lastMaybe :: Maybe a -> Maybe a -> Maybe a +lastMaybe l r = getLast <$> fmap Last l <> fmap Last r + +leftToMaybe :: Either e a -> Maybe e +leftToMaybe (Left x) = Just x +leftToMaybe _ = Nothing + +rightToMaybe :: Either e a -> Maybe a +rightToMaybe (Right x) = Just x +rightToMaybe _ = Nothing + +justToEither :: Maybe e -> Either e () +justToEither (Just x) = Left x +justToEither _ = Right () + +(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<<$>>) = fmap . fmap + +infixl 4 <<$>> + +(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) +(<<*>>) = liftA2 (<*>) + +infixl 4 <<*>> + +(<.>) :: (Functor f) => (a -> b) -> (c -> f a) -> (c -> f b) +(<.>) f g x = f <$> g x + +infixl 4 <.> + +debug :: (P.Member LogEff r) => Text -> P.Sem r () +debug = Di.debug + +info :: (P.Member LogEff r) => Text -> P.Sem r () +info = Di.info + +error :: (P.Member LogEff r) => Text -> P.Sem r () +error = Di.error + +swap :: (a, b) -> (b, a) +swap ~(a, b) = (b, a) + +newtype DefaultingMap k v = DefaultingMap {unDefaultingMap :: M.Map k v} + +instance Default (DefaultingMap k v) where + def = DefaultingMap M.empty + +newtype AesonVector a = AesonVector {unAesonVector :: VU.Vector a} + deriving (Show) via VU.Vector a + +instance (Aeson.FromJSON a, VU.Unboxable a) => Aeson.FromJSON (AesonVector a) where + parseJSON = (AesonVector . VU.fromList <$>) . Aeson.parseJSON + +instance (Aeson.ToJSON a, VU.Unboxable a) => Aeson.ToJSON (AesonVector a) where + toJSON = Aeson.toJSON . VU.toList . unAesonVector + toEncoding = Aeson.toEncoding . VU.toList . unAesonVector + +instance (TextShow a, VU.Unboxable a) => TextShow (AesonVector a) where + showb = showbList . VU.toList . unAesonVector + +newtype CalamityFromStringShow a = CalamityFromStringShow {unCalamityFromStringShow :: a} + deriving (Aeson.FromJSON, Aeson.ToJSON) via a + deriving (TextShow) via FromStringShow a + +{- | An alternative 'Maybe' type that allows us to distinguish between parsed + json fields that were null, and fields that didn't exist. +-} +data MaybeNull a + = WasNull + | NotNull a + deriving (Show) + +instance (Aeson.FromJSON a) => Aeson.FromJSON (MaybeNull a) where + parseJSON Aeson.Null = pure WasNull + parseJSON x = NotNull <$> Aeson.parseJSON x + +instance (Aeson.ToJSON a) => Aeson.ToJSON (MaybeNull a) where + toJSON WasNull = Aeson.Null + toJSON (NotNull x) = Aeson.toJSON x + + toEncoding WasNull = null_ + toEncoding (NotNull x) = Aeson.toEncoding x + +#if MIN_VERSION_aeson(2,2,0) +(.?=) :: (Aeson.ToJSON v, Aeson.KeyValue e kv) => Aeson.Key -> Maybe v -> Maybe kv +k .?= Just v = Just (k Aeson..= v) +_ .?= Nothing = Nothing + +(.=) :: (Aeson.ToJSON v, Aeson.KeyValue e kv) => Aeson.Key -> v -> Maybe kv +k .= v = Just (k Aeson..= v) + +class CalamityToJSON' a where + toPairs :: Aeson.KeyValue v kv => a -> [Maybe kv] +#else +(.?=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> Maybe v -> Maybe kv +k .?= Just v = Just (k Aeson..= v) +_ .?= Nothing = Nothing + +(.=) :: (Aeson.ToJSON v, Aeson.KeyValue kv) => Aeson.Key -> v -> Maybe kv +k .= v = Just (k Aeson..= v) + +class CalamityToJSON' a where + toPairs :: Aeson.KeyValue kv => a -> [Maybe kv] +#endif + +newtype CalamityToJSON a = CalamityToJSON a + +instance (CalamityToJSON' a) => Aeson.ToJSON (CalamityToJSON a) where + toJSON (CalamityToJSON x) = Aeson.object . catMaybes . toPairs $ x + toEncoding (CalamityToJSON x) = Aeson.pairs . mconcat . catMaybes . toPairs $ x diff --git a/Calamity/Metrics/Eff.hs b/Calamity/Metrics/Eff.hs new file mode 100644 --- /dev/null +++ b/Calamity/Metrics/Eff.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Effect for handling metrics +module Calamity.Metrics.Eff ( + Counter, + Gauge, + Histogram, + HistogramSample (..), + MetricEff (..), + registerCounter, + registerGauge, + registerHistogram, + addCounter, + modifyGauge, + observeHistogram, +) where + +import Calamity.Metrics.Internal +import Data.Default.Class +import Data.Map qualified as Map +import Data.Text +import Optics.TH +import Polysemy +import TextShow + +data HistogramSample = HistogramSample + { buckets :: Map.Map Double Double + , sum :: Double + , count :: Int + } + deriving (Eq, Show) + deriving + (TextShow) + via FromStringShow HistogramSample + +instance Default HistogramSample where + def = HistogramSample Map.empty 0.0 0 + +data MetricEff m a where + -- | Register a 'Counter' + RegisterCounter :: + -- | Name + Text -> + -- | Labels + [(Text, Text)] -> + MetricEff m Counter + -- | Register a 'Gauge' + RegisterGauge :: + -- | Name + Text -> + -- | Labels + [(Text, Text)] -> + MetricEff m Gauge + -- | Register a 'Histogram' + RegisterHistogram :: + -- | Name + Text -> + -- | Labels + [(Text, Text)] -> + -- | Upper bounds + [Double] -> + MetricEff m Histogram + AddCounter :: Int -> Counter -> MetricEff m Int + ModifyGauge :: (Double -> Double) -> Gauge -> MetricEff m Double + ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample + +makeSem ''MetricEff + +$(makeFieldLabelsNoPrefix ''HistogramSample) diff --git a/Calamity/Metrics/Internal.hs b/Calamity/Metrics/Internal.hs new file mode 100644 --- /dev/null +++ b/Calamity/Metrics/Internal.hs @@ -0,0 +1,21 @@ +-- | Internal data structures to the metrics effect +module Calamity.Metrics.Internal ( + Counter (..), + Gauge (..), + Histogram (..), +) where + +-- | A handle to a counter +newtype Counter = Counter + { unCounter :: Int + } + +-- | A handle to a gauge +newtype Gauge = Gauge + { unGauge :: Int + } + +-- | A handle to a histogram +newtype Histogram = Histogram + { unHistogram :: Int + } diff --git a/Calamity/Metrics/Noop.hs b/Calamity/Metrics/Noop.hs new file mode 100644 --- /dev/null +++ b/Calamity/Metrics/Noop.hs @@ -0,0 +1,18 @@ +-- | Noop handler for metrics +module Calamity.Metrics.Noop (runMetricsNoop) where + +import Calamity.Metrics.Eff +import Calamity.Metrics.Internal + +import Data.Default.Class + +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 diff --git a/Calamity/Types.hs b/Calamity/Types.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types.hs @@ -0,0 +1,38 @@ +-- | All user facing types +module Calamity.Types ( + module Calamity.Types.Model, + module Calamity.Types.Partial, + module Calamity.Types.Snowflake, + module Calamity.Types.Token, + module Calamity.Types.Tellable, + module Calamity.Types.Upgradeable, + module Calamity.Types.CDNAsset, + module Calamity.Types.TokenEff, + module Calamity.Types.LogEff, + + -- * Types + -- $typesDocs +) where + +import Calamity.Types.CDNAsset +import Calamity.Types.LogEff +import Calamity.Types.Model +import Calamity.Types.Partial +import Calamity.Types.Snowflake +import Calamity.Types.Tellable +import Calamity.Types.Token +import Calamity.Types.TokenEff +import Calamity.Types.Upgradeable + +{- $typesDocs + + This module collects all discord models, and other useful types together. + + The 'Tellable' class allows you to construct and send + messages to things to you can send messages to in a neat way. + + The 'Upgradeable' class allows you to upgrade a snowflake to the full value + it refers to. + + The 'CDNAsset' class allows you to fetch assets from the discord CDN. +-} diff --git a/Calamity/Types/CDNAsset.hs b/Calamity/Types/CDNAsset.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/CDNAsset.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- | Things that can be fetched from the discord CDN +module Calamity.Types.CDNAsset ( + CDNAsset (..), + fetchAsset, + fetchAsset', +) +where + +import Control.Exception.Safe qualified as Ex +import Data.ByteString.Lazy (ByteString) +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 +fetchAsset' a = Req.responseBody <$> Req.req Req.GET (assetURL a) Req.NoReqBody Req.lbsResponse mempty + +-- | Retrieve the asset from the CDN +fetchAsset :: (CDNAsset a, P.Member (P.Embed IO) r) => a -> P.Sem r (Either Req.HttpException ByteString) +fetchAsset a = P.embed $ Ex.catch (Right <$> r) (\(e :: Req.HttpException) -> pure $ Left e) + where + r = Req.runReq reqConfig $ fetchAsset' a + +reqConfig :: Req.HttpConfig +reqConfig = + Req.defaultHttpConfig + { Req.httpConfigCheckResponse = \_ _ _ -> Nothing + } + +class CDNAsset a where + assetURL :: a -> Req.Url 'Req.Https diff --git a/Calamity/Types/LogEff.hs b/Calamity/Types/LogEff.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/LogEff.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The logging effect we use +module Calamity.Types.LogEff ( + LogEff, + LogC, +) where + +import Df1 qualified + +import DiPolysemy + +import Polysemy qualified as P + +type LogEff = Di Df1.Level Df1.Path Df1.Message + +type LogC r = P.Member LogEff r diff --git a/Calamity/Types/Model.hs b/Calamity/Types/Model.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model.hs @@ -0,0 +1,18 @@ +-- | Discord data models +module Calamity.Types.Model ( + module Calamity.Types.Model.Channel, + module Calamity.Types.Model.Guild, + module Calamity.Types.Model.Presence, + module Calamity.Types.Model.User, + module Calamity.Types.Model.Voice, + module Calamity.Types.Model.Avatar, + module Calamity.Types.Model.Interaction, +) where + +import Calamity.Types.Model.Avatar +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.Interaction +import Calamity.Types.Model.Presence +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice diff --git a/Calamity/Types/Model/Avatar.hs b/Calamity/Types/Model/Avatar.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Avatar.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Calamity.Types.Model.Avatar ( + Avatar (..), + MemberAvatar (..), +) where + +import Calamity.Types.CDNAsset (CDNAsset (..)) +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import {-# SOURCE #-} Calamity.Types.Model.User +import Calamity.Types.Snowflake (Snowflake, fromSnowflake) +import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) +import Data.Text qualified as T +import Network.HTTP.Req ((/:), (/~)) +import Optics (makeFieldLabelsNoPrefix) +import TextShow (showt) +import TextShow.TH (deriveTextShow) + +data Avatar = Avatar + { hash :: Maybe T.Text + , userID :: Snowflake User + , discrim :: Int + } + deriving (Show, Eq) + +instance CDNAsset Avatar where + assetURL Avatar {hash = Just h, userID} = + cdnURL /: "avatars" /~ fromSnowflake userID /: assetHashFile h + assetURL Avatar {discrim} = + cdnURL /: "embed" /: "avatars" /: (showt (discrim `mod` 5) <> ".png") + +-- | A member's custom guild avatar +data MemberAvatar = MemberAvatar + { hash :: T.Text + , guildID :: Snowflake Guild + , userID :: Snowflake User + } + deriving (Show, Eq) + +instance CDNAsset MemberAvatar where + assetURL MemberAvatar {hash, guildID, userID} = + cdnURL /: "guilds" /~ guildID /: "users" /~ userID /: "avatars" /: assetHashFile hash + +$(deriveTextShow ''Avatar) +$(makeFieldLabelsNoPrefix ''Avatar) +$(deriveTextShow ''MemberAvatar) +$(makeFieldLabelsNoPrefix ''MemberAvatar) diff --git a/Calamity/Types/Model/Channel.hs b/Calamity/Types/Model/Channel.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | The generic channel type +module Calamity.Types.Model.Channel ( + Channel (..), + Partial (PartialChannel), + module Calamity.Types.Model.Channel.DM, + module Calamity.Types.Model.Channel.Group, + module Calamity.Types.Model.Channel.Guild, + module Calamity.Types.Model.Channel.Attachment, + module Calamity.Types.Model.Channel.Reaction, + module Calamity.Types.Model.Channel.Webhook, + module Calamity.Types.Model.Channel.Embed, + module Calamity.Types.Model.Channel.ChannelType, + module Calamity.Types.Model.Channel.Message, + module Calamity.Types.Model.Channel.Component, +) where + +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel.Attachment +import Calamity.Types.Model.Channel.ChannelType +import Calamity.Types.Model.Channel.Component +import Calamity.Types.Model.Channel.DM +import Calamity.Types.Model.Channel.Embed +import Calamity.Types.Model.Channel.Group +import Calamity.Types.Model.Channel.Guild +import Calamity.Types.Model.Channel.Message +import Calamity.Types.Model.Channel.Reaction +import Calamity.Types.Model.Channel.Webhook +import Calamity.Types.Model.Guild.Permissions (Permissions) +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data Channel + = DMChannel' DMChannel + | GroupChannel' GroupChannel + | GuildChannel' GuildChannel + deriving (Show, Eq) + +instance HasID Channel Channel where + getID (DMChannel' a) = getID a + getID (GroupChannel' a) = getID a + getID (GuildChannel' a) = getID a + +instance Aeson.FromJSON Channel where + parseJSON = Aeson.withObject "Channel" $ \v -> do + type_ <- v Aeson..: "type" + + case type_ of + GuildTextType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildVoiceType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildCategoryType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + DMType -> DMChannel' <$> Aeson.parseJSON (Aeson.Object v) + GroupDMType -> GroupChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildNewsType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildNewsThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildPublicThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildPrivateThreadType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildStageVoiceType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildDirectoryType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + GuildForumType -> GuildChannel' <$> Aeson.parseJSON (Aeson.Object v) + +data instance Partial Channel = PartialChannel + { id :: Snowflake Channel + , name :: Text + , type_ :: ChannelType + , permissions :: Maybe Permissions + , parentID :: Maybe (Snowflake Category) + } + deriving (Show, Eq) + deriving (HasID Channel) via HasIDField "id" (Partial Channel) + deriving (Aeson.ToJSON) via CalamityToJSON (Partial Channel) + +instance CalamityToJSON' (Partial Channel) where + toPairs PartialChannel {..} = + [ "id" .= id + , "name" .= name + , "type" .= type_ + , "permissions" .?= permissions + , "parent_id" .?= parentID + ] + +instance Aeson.FromJSON (Partial Channel) where + parseJSON = Aeson.withObject "Partial Channel" $ \v -> + PartialChannel + <$> v .: "id" + <*> v .: "name" + <*> v .: "type" + <*> v .:? "permissions" + <*> v .:? "parent_id" + +$(deriveTextShow ''Channel) +$(deriveTextShow 'PartialChannel) +$(makeFieldLabelsNoPrefix ''Channel) +$(makeFieldLabelsNoPrefix 'PartialChannel) diff --git a/Calamity/Types/Model/Channel.hs-boot b/Calamity/Types/Model/Channel.hs-boot new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel.hs-boot @@ -0,0 +1,7 @@ +-- | The generic channel type +module Calamity.Types.Model.Channel + ( Channel ) where + +data Channel +instance Show Channel +instance Eq Channel diff --git a/Calamity/Types/Model/Channel/Attachment.hs b/Calamity/Types/Model/Channel/Attachment.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Attachment.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Message attachments +module Calamity.Types.Model.Channel.Attachment ( + Attachment (..), +) where + +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Word +import Optics.TH +import TextShow.TH + +fuseTup2 :: (Monad f) => (f a, f b) -> f (a, b) +fuseTup2 (a, b) = do + !a' <- a + !b' <- b + pure (a', b') + +data Attachment = Attachment + { id :: Snowflake Attachment + , filename :: Text + , size :: Word64 + , url :: Text + , proxyUrl :: Text + , dimensions :: Maybe (Word64, Word64) + } + deriving (Eq, Show) + deriving (HasID Attachment) via HasIDField "id" Attachment + +$(deriveTextShow ''Attachment) +$(makeFieldLabelsNoPrefix ''Attachment) + +instance Aeson.FromJSON Attachment where + parseJSON = Aeson.withObject "Attachment" $ \v -> do + width <- v .:? "width" + height <- v .:? "height" + + Attachment + <$> v .: "id" + <*> v .: "filename" + <*> v .: "size" + <*> v .: "url" + <*> v .: "proxy_url" + <*> pure + (fuseTup2 (width, height)) diff --git a/Calamity/Types/Model/Channel/ChannelType.hs b/Calamity/Types/Model/Channel/ChannelType.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/ChannelType.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Types of channels +module Calamity.Types.Model.Channel.ChannelType (ChannelType (..)) where + +import Data.Aeson qualified as Aeson +import Data.Scientific +import Optics.TH +import TextShow.TH + +-- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182) +data ChannelType + = GuildTextType + | DMType + | GuildVoiceType + | GroupDMType + | GuildCategoryType + | GuildNewsType + | GuildNewsThreadType + | GuildPublicThreadType + | GuildPrivateThreadType + | GuildStageVoiceType + | GuildDirectoryType + | GuildForumType + deriving (Eq, Show, Enum) + +$(deriveTextShow ''ChannelType) +$(makeFieldLabelsNoPrefix ''ChannelType) + +instance Aeson.ToJSON ChannelType where + toJSON t = Aeson.Number $ case t of + GuildTextType -> 0 + DMType -> 1 + GuildVoiceType -> 2 + GroupDMType -> 3 + GuildCategoryType -> 4 + GuildNewsType -> 5 + GuildNewsThreadType -> 10 + GuildPublicThreadType -> 11 + GuildPrivateThreadType -> 12 + GuildStageVoiceType -> 13 + GuildDirectoryType -> 14 + GuildForumType -> 15 + +instance Aeson.FromJSON ChannelType where + parseJSON = Aeson.withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 0 -> pure GuildTextType + 1 -> pure DMType + 2 -> pure GuildVoiceType + 3 -> pure GroupDMType + 4 -> pure GuildCategoryType + 5 -> pure GuildNewsType + 10 -> pure GuildNewsThreadType + 11 -> pure GuildPublicThreadType + 12 -> pure GuildPrivateThreadType + 13 -> pure GuildStageVoiceType + 14 -> pure GuildDirectoryType + 15 -> pure GuildForumType + _ -> fail $ "Invalid ChannelType: " <> show n + Nothing -> fail $ "Invalid ChannelType: " <> show n diff --git a/Calamity/Types/Model/Channel/Component.hs b/Calamity/Types/Model/Channel/Component.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Component.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Message components +module Calamity.Types.Model.Channel.Component ( + CustomID (..), + Component (..), + Button (..), + LinkButton (..), + button, + button', + lbutton, + lbutton', + ButtonStyle (..), + Select (..), + select, + SelectOption (..), + sopt, + TextInput (..), + TextInputStyle (..), + textInput, + ComponentType (..), + componentType, +) where + +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Calamity.Types.Model.Guild.Emoji +import Control.Monad (replicateM) +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Maybe (catMaybes) +import Data.Scientific (toBoundedInteger) +import Data.Text qualified as T +import Optics.TH +import System.Random (Uniform) +import System.Random.Stateful (Uniform (uniformM), UniformRange (uniformRM)) +import TextShow.TH + +newtype CustomID = CustomID T.Text + deriving stock (Eq, Ord, Show) + deriving (Aeson.ToJSON, Aeson.FromJSON) via T.Text + +$(deriveTextShow ''CustomID) + +instance Uniform CustomID where + uniformM = ((CustomID . T.pack) <$>) . replicateM 16 . uniformRM ('a', 'z') + +data ComponentType + = ActionRowType + | ButtonType + | SelectType + | TextInputType + deriving (Eq, Show) + +$(deriveTextShow ''ComponentType) + +instance Aeson.ToJSON ComponentType where + toJSON x = Aeson.toJSON @Int $ case x of + ActionRowType -> 1 + ButtonType -> 2 + SelectType -> 3 + TextInputType -> 4 + toEncoding x = Aeson.toEncoding @Int $ case x of + ActionRowType -> 1 + ButtonType -> 2 + SelectType -> 3 + TextInputType -> 4 + +instance Aeson.FromJSON ComponentType where + parseJSON = Aeson.withScientific "Components.ComponentType" $ \n -> case toBoundedInteger @Int n of + Just 1 -> pure ActionRowType + Just 2 -> pure ButtonType + Just 3 -> pure SelectType + Just 4 -> pure TextInputType + _ -> fail $ "Invalid ComponentType: " <> show n + +data ButtonStyle + = ButtonPrimary + | ButtonSecondary + | ButtonSuccess + | ButtonDanger + | ButtonLink + deriving (Eq, Show) + +$(deriveTextShow ''ButtonStyle) + +instance Aeson.ToJSON ButtonStyle where + toJSON t = Aeson.toJSON @Int $ case t of + ButtonPrimary -> 1 + ButtonSecondary -> 2 + ButtonSuccess -> 3 + ButtonDanger -> 4 + ButtonLink -> 5 + toEncoding t = Aeson.toEncoding @Int $ case t of + ButtonPrimary -> 1 + ButtonSecondary -> 2 + ButtonSuccess -> 3 + ButtonDanger -> 4 + ButtonLink -> 5 + +instance Aeson.FromJSON ButtonStyle where + parseJSON = Aeson.withScientific "Components.ButtonStyle" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 1 -> pure ButtonPrimary + 2 -> pure ButtonSecondary + 3 -> pure ButtonSuccess + 4 -> pure ButtonDanger + 5 -> pure ButtonLink + _ -> fail $ "Invalid ButtonStyle: " <> show n + Nothing -> fail $ "Invalid ButtonStyle: " <> show n + +data Button = Button + { style :: ButtonStyle + , label :: Maybe T.Text + , emoji :: Maybe RawEmoji + , disabled :: Bool + , customID :: CustomID + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON Button + +instance CalamityToJSON' Button where + toPairs Button {..} = + [ "style" .= style + , "label" .?= label + , "emoji" .?= emoji + , "disabled" .= disabled + , "custom_id" .= customID + , "type" .= ButtonType + ] + +$(deriveTextShow ''Button) +$(makeFieldLabelsNoPrefix ''Button) + +instance Aeson.FromJSON Button where + parseJSON = Aeson.withObject "Components.Button" $ \v -> + Button + <$> v .: "style" + <*> v .:? "label" + <*> v .:? "emoji" + <*> v .:? "disabled" .!= False + <*> v .: "custom_id" + +data LinkButton = LinkButton + { style :: ButtonStyle + , label :: Maybe T.Text + , emoji :: Maybe RawEmoji + , url :: T.Text + , disabled :: Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON LinkButton + +instance CalamityToJSON' LinkButton where + toPairs LinkButton {..} = + [ "style" .= style + , "label" .?= label + , "emoji" .?= emoji + , "url" .= url + , "disabled" .= disabled + , "type" .= ButtonType + ] + +instance Aeson.FromJSON LinkButton where + parseJSON = Aeson.withObject "Components.Linkbutton" $ \v -> + LinkButton + <$> v .: "style" + <*> v .:? "label" + <*> v .:? "emoji" + <*> v .: "url" + <*> v .:? "disabled" .!= False + +$(deriveTextShow ''LinkButton) +$(makeFieldLabelsNoPrefix ''LinkButton) + +{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle' and 'CustomID', + all other fields are set to 'Nothing' +-} +button :: ButtonStyle -> CustomID -> Button +button s = Button s Nothing Nothing False + +{- | Constuct a non-disabled 'Button' with the given 'ButtonStyle', 'CustomID', + and label, all other fields are set to 'Nothing' +-} +button' :: ButtonStyle -> T.Text -> CustomID -> Button +button' s l = Button s (Just l) Nothing False + +{- | Constuct a non-disabled 'LinkButton' with the given 'ButtonStyle', link, all + other fields are set to 'Nothing' +-} +lbutton :: + ButtonStyle -> + -- | The link to use + T.Text -> + LinkButton +lbutton s lnk = LinkButton s Nothing Nothing lnk False + +{- | Constuct a non-disabled 'LinkButton' with the given 'ButtonStyle', link, + and label, all other fields are set to 'Nothing' +-} +lbutton' :: + ButtonStyle -> + -- | The link to use + T.Text -> + -- | The label to use + T.Text -> + LinkButton +lbutton' s lnk lbl = LinkButton s (Just lbl) Nothing lnk False + +data SelectOption = SelectOption + { label :: T.Text + , value :: T.Text + , description :: Maybe T.Text + , emoji :: Maybe RawEmoji + , default_ :: Bool + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON SelectOption + +instance CalamityToJSON' SelectOption where + toPairs SelectOption {..} = + [ "label" .= label + , "value" .= value + , "description" .?= description + , "emoji" .?= emoji + , "default" .= default_ + ] + +instance Aeson.FromJSON SelectOption where + parseJSON = Aeson.withObject "Components.SelectOption" $ \v -> + SelectOption + <$> v .: "label" + <*> v .: "value" + <*> v .:? "description" + <*> v .:? "emoji" + <*> v .:? "default" .!= False + +$(deriveTextShow ''SelectOption) +$(makeFieldLabelsNoPrefix ''SelectOption) + +data Select = Select + { options :: [SelectOption] + , placeholder :: Maybe T.Text + , minValues :: Maybe Int + , maxValues :: Maybe Int + , disabled :: Bool + , customID :: CustomID + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON Select + +instance CalamityToJSON' Select where + toPairs Select {..} = + [ "options" .= options + , "placeholder" .?= placeholder + , "min_values" .?= minValues + , "max_values" .?= maxValues + , "disabled" .= disabled + , "custom_id" .= customID + , "type" .= SelectType + ] + +instance Aeson.FromJSON Select where + parseJSON = Aeson.withObject "Components.Select" $ \v -> + Select + <$> v .: "options" + <*> v .:? "placeholder" + <*> v .:? "min_values" + <*> v .:? "max_values" + <*> v .:? "disabled" .!= False + <*> v .: "custom_id" + +$(deriveTextShow ''Select) +$(makeFieldLabelsNoPrefix ''Select) + +select :: [SelectOption] -> CustomID -> Select +select o = Select o Nothing Nothing Nothing False + +sopt :: + -- | Label + T.Text -> + -- | Value + T.Text -> + SelectOption +sopt l v = SelectOption l v Nothing Nothing False + +data TextInputStyle + = TextInputShort + | TextInputParagraph + deriving (Show) + +$(deriveTextShow ''TextInputStyle) + +instance Aeson.ToJSON TextInputStyle where + toJSON t = Aeson.toJSON @Int $ case t of + TextInputShort -> 1 + TextInputParagraph -> 2 + toEncoding t = Aeson.toEncoding @Int $ case t of + TextInputShort -> 1 + TextInputParagraph -> 2 + +instance Aeson.FromJSON TextInputStyle where + parseJSON = Aeson.withScientific "Components.TextInputStyle" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 1 -> pure TextInputShort + 2 -> pure TextInputParagraph + _ -> fail $ "Invalid TextInputStyle: " <> show n + Nothing -> fail $ "Invalid TextInputStyle: " <> show n + +data TextInput = TextInput + { style :: TextInputStyle + , label :: T.Text + , minLength :: Maybe Int + , maxLength :: Maybe Int + , required :: Bool + , value :: Maybe T.Text + , placeholder :: Maybe T.Text + , customID :: CustomID + } + deriving (Show) + deriving (Aeson.ToJSON) via CalamityToJSON TextInput + +instance CalamityToJSON' TextInput where + toPairs TextInput {..} = + [ "style" .= style + , "label" .= label + , "min_length" .= minLength + , "max_length" .= maxLength + , "required" .= required + , "value" .= value + , "placeholder" .= placeholder + , "custom_id" .= customID + , "type" .= TextInputType + ] + +instance Aeson.FromJSON TextInput where + parseJSON = Aeson.withObject "Components.TextInput" $ \v -> + TextInput + <$> v .: "style" + <*> v .: "label" + <*> v .:? "min_length" + <*> v .:? "max_length" + <*> v .:? "required" .!= False + <*> v .:? "value" + <*> v .:? "placeholder" + <*> v .: "custom_id" + +$(deriveTextShow ''TextInput) +$(makeFieldLabelsNoPrefix ''TextInput) + +textInput :: + TextInputStyle -> + -- | Label + T.Text -> + CustomID -> + TextInput +textInput s l = TextInput s l Nothing Nothing True Nothing Nothing + +data Component + = ActionRow' [Component] + | Button' Button + | LinkButton' LinkButton + | Select' Select + | TextInput' TextInput + deriving (Show) + +$(deriveTextShow ''Component) + +instance Aeson.ToJSON Component where + toJSON t = + case t of + ActionRow' xs -> Aeson.object . catMaybes $ ["components" .= xs, "type" .= ActionRowType] + Button' b -> Aeson.toJSON b + LinkButton' lb -> Aeson.toJSON lb + Select' s -> Aeson.toJSON s + TextInput' ti -> Aeson.toJSON ti + + toEncoding t = + case t of + ActionRow' xs -> Aeson.pairs . mconcat . catMaybes $ ["components" .= xs, "type" .= ActionRowType] + Button' b -> Aeson.toEncoding b + LinkButton' lb -> Aeson.toEncoding lb + Select' s -> Aeson.toEncoding s + TextInput' ti -> Aeson.toEncoding ti + +instance Aeson.FromJSON Component where + parseJSON = Aeson.withObject "Component" $ \v -> do + type_ :: ComponentType <- v .: "type" + + case type_ of + ActionRowType -> ActionRow' <$> v .: "components" + ButtonType -> do + cid :: Maybe CustomID <- v .:? "custom_id" + url :: Maybe T.Text <- v .:? "url" + case (cid, url) of + (Just _, _) -> Button' <$> Aeson.parseJSON (Aeson.Object v) + (_, Just _) -> LinkButton' <$> Aeson.parseJSON (Aeson.Object v) + _ -> fail $ "Impossible button: " <> show v + SelectType -> Select' <$> Aeson.parseJSON (Aeson.Object v) + TextInputType -> TextInput' <$> Aeson.parseJSON (Aeson.Object v) + +componentType :: Component -> ComponentType +componentType (ActionRow' _) = ActionRowType +componentType (Button' _) = ButtonType +componentType (LinkButton' _) = ButtonType +componentType (Select' _) = SelectType +componentType (TextInput' _) = TextInputType diff --git a/Calamity/Types/Model/Channel/DM.hs b/Calamity/Types/Model/Channel/DM.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/DM.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A DM channel with a single person +module Calamity.Types.Model.Channel.DM (DMChannel (..)) where + +import {-# SOURCE #-} Calamity.Types.Model.Channel +import {-# SOURCE #-} Calamity.Types.Model.Channel.Message +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Time +import Optics.TH +import TextShow qualified + +data DMChannel = DMChannel + { id :: Snowflake DMChannel + , lastMessageID :: Maybe (Snowflake Message) + , lastPinTimestamp :: Maybe UTCTime + , recipients :: [User] + } + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow DMChannel + deriving (HasID DMChannel) via HasIDField "id" DMChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" DMChannel + +instance Aeson.FromJSON DMChannel where + parseJSON = Aeson.withObject "DMChannel" $ \v -> + DMChannel + <$> v .: "id" + <*> v .:? "last_pin_timestamp" + <*> v .:? "last_message_id" + <*> v .: "recipients" + +$(makeFieldLabelsNoPrefix ''DMChannel) diff --git a/Calamity/Types/Model/Channel/Embed.hs b/Calamity/Types/Model/Channel/Embed.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Embed.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Message embeds +module Calamity.Types.Model.Channel.Embed ( + Embed (..), + embedFooter, + embedImage, + embedThumbnail, + embedAuthor, + embedAuthor', + embedField, + EmbedFooter (..), + EmbedImage (..), + EmbedThumbnail (..), + EmbedVideo (..), + EmbedProvider (..), + EmbedAuthor (..), + EmbedField (..), +) where + +import Calamity.Internal.IntColour (IntColour (..)) +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Colour (Colour) +import Data.Default.Class +import Data.Semigroup +import Data.Text (Text) +import Data.Time +import Data.Word +import Optics ((%~), (&), (^.)) +import Optics.TH +import TextShow qualified +import TextShow.TH + +data Embed = Embed + { title :: Maybe Text + , type_ :: Maybe Text + , description :: Maybe Text + , url :: Maybe Text + , timestamp :: Maybe UTCTime + , color :: Maybe (Colour Double) + , footer :: Maybe EmbedFooter + , image :: Maybe EmbedImage + , thumbnail :: Maybe EmbedThumbnail + , video :: Maybe EmbedVideo + , provider :: Maybe EmbedProvider + , author :: Maybe EmbedAuthor + , fields :: [EmbedField] + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Embed + deriving (Aeson.ToJSON) via CalamityToJSON Embed + +instance Default Embed where + def = + Embed + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + [] + +instance CalamityToJSON' Embed where + toPairs Embed {..} = + [ "title" .?= title + , "type" .?= type_ + , "description" .?= description + , "url" .?= url + , "timestamp" .?= timestamp + , "color" .?= (IntColour <$> color) + , "footer" .?= footer + , "image" .?= image + , "thumbnail" .?= thumbnail + , "video" .?= video + , "provider" .?= provider + , "author" .?= author + , "fields" .= fields + ] + +instance Aeson.FromJSON Embed where + parseJSON = Aeson.withObject "Embed" $ \v -> + Embed + <$> v .:? "title" + <*> v .:? "type" + <*> v .:? "description" + <*> v .:? "url" + <*> v .:? "timestamp" + <*> (fmap fromIntColour <$> v .:? "color") + <*> v .:? "footer" + <*> v .:? "image" + <*> v .:? "thumbnail" + <*> v .:? "video" + <*> v .:? "provider" + <*> v .:? "author" + <*> v .:? "fields" .!= [] + +data EmbedFooter = EmbedFooter + { text :: Text + , iconUrl :: Maybe Text + , proxyIconUrl :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedFooter + +instance CalamityToJSON' EmbedFooter where + toPairs EmbedFooter {..} = + [ "text" .= text + , "icon_url" .?= iconUrl + , "proxy_icon_url" .?= proxyIconUrl + ] + +instance Aeson.FromJSON EmbedFooter where + parseJSON = Aeson.withObject "EmbedFooter" $ \v -> + EmbedFooter + <$> v .: "text" + <*> v .:? "icon_url" + <*> v .:? "proxy_icon_url" + +{- | Create an embed footer with a provided content + + The remaining fields are set to Nothing +-} +embedFooter :: Text -> EmbedFooter +embedFooter text = EmbedFooter text Nothing Nothing + +data EmbedImage = EmbedImage + { url :: Text + , proxyUrl :: Maybe Text + , width :: Maybe Word64 + , height :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedImage + +instance CalamityToJSON' EmbedImage where + toPairs EmbedImage {..} = + [ "url" .= url + , "proxy_url" .= proxyUrl + , "width" .= width + , "height" .= height + ] + +instance Aeson.FromJSON EmbedImage where + parseJSON = Aeson.withObject "EmbedImage" $ \v -> + EmbedImage + <$> v .: "url" + <*> v .:? "proxy_url" + <*> v .:? "width" + <*> v .:? "height" + +{- | Create an embed image with a provided url + + The remaining fields are set to Nothing +-} +embedImage :: Text -> EmbedImage +embedImage url = EmbedImage url Nothing Nothing Nothing + +data EmbedThumbnail = EmbedThumbnail + { url :: Text + , proxyUrl :: Maybe Text + , width :: Maybe Word64 + , height :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedThumbnail + +instance CalamityToJSON' EmbedThumbnail where + toPairs EmbedThumbnail {..} = + [ "url" .= url + , "proxy_url" .?= proxyUrl + , "width" .?= width + , "height" .?= height + ] + +instance Aeson.FromJSON EmbedThumbnail where + parseJSON = Aeson.withObject "EmbedThumbnail" $ \v -> + EmbedThumbnail + <$> v .: "url" + <*> v .:? "proxy_url" + <*> v .:? "width" + <*> v .:? "height" + +{- | Create an embed thumbnail with a provided url + + The remaining fields are set to Nothing +-} +embedThumbnail :: Text -> EmbedThumbnail +embedThumbnail url = EmbedThumbnail url Nothing Nothing Nothing + +data EmbedVideo = EmbedVideo + { url :: Maybe Text + , proxyUrl :: Maybe Text + , width :: Maybe Word64 + , height :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedVideo + +instance CalamityToJSON' EmbedVideo where + toPairs EmbedVideo {..} = + [ "url" .= url + , "proxy_url" .= proxyUrl + , "width" .= width + , "height" .= height + ] + +instance Aeson.FromJSON EmbedVideo where + parseJSON = Aeson.withObject "EmbedVideo" $ \v -> + EmbedVideo + <$> v .: "url" + <*> v .:? "proxy_url" + <*> v .:? "width" + <*> v .:? "height" + +data EmbedProvider = EmbedProvider + { name :: Maybe Text + , url :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedProvider + +instance CalamityToJSON' EmbedProvider where + toPairs EmbedProvider {..} = + [ "name" .= name + , "url" .= url + ] + +instance Aeson.FromJSON EmbedProvider where + parseJSON = Aeson.withObject "EmbedProvider" $ \v -> + EmbedProvider + <$> v .:? "name" + <*> v .:? "url" + +data EmbedAuthor = EmbedAuthor + { name :: Maybe Text + , url :: Maybe Text + , iconUrl :: Maybe Text + , proxyIconUrl :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedAuthor + +instance Default EmbedAuthor where + def = EmbedAuthor Nothing Nothing Nothing Nothing + +instance CalamityToJSON' EmbedAuthor where + toPairs EmbedAuthor {..} = + [ "name" .?= name + , "url" .?= url + , "icon_url" .?= iconUrl + , "proxy_icon_url" .?= proxyIconUrl + ] + +instance Aeson.FromJSON EmbedAuthor where + parseJSON = Aeson.withObject "EmbedAuthor" $ \v -> + EmbedAuthor + <$> v .:? "name" + <*> v .:? "url" + <*> v .:? "icon_url" + <*> v .:? "proxy_icon_url" + +{- | Create an embed author with the given name + + The remaining fields are set to Nothing +-} +embedAuthor :: Text -> EmbedAuthor +embedAuthor name = EmbedAuthor (Just name) Nothing Nothing Nothing + +{- | Create an embed author with the given name, url, and icon url + + The remaining fields are set to Nothing +-} +embedAuthor' :: + -- | Name + Text -> + -- | Url + Text -> + -- | Icon url + Text -> + EmbedAuthor +embedAuthor' name url iconUrl = EmbedAuthor (Just name) (Just url) (Just iconUrl) Nothing + +data EmbedField = EmbedField + { name :: Text + , value :: Text + , inline :: Bool + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON EmbedField + +instance CalamityToJSON' EmbedField where + toPairs EmbedField {..} = + [ "name" .= name + , "value" .= value + , "inline" .= inline + ] + +instance Aeson.FromJSON EmbedField where + parseJSON = Aeson.withObject "EmbedField" $ \v -> + EmbedField + <$> v .: "name" + <*> v .: "value" + <*> v .:? "inline" .!= False + +-- | Create a non-inline embed field +embedField :: + -- | Name + Text -> + -- | Value + Text -> + EmbedField +embedField name value = EmbedField name value False + +$(makeFieldLabelsNoPrefix ''Embed) + +$(deriveTextShow ''EmbedFooter) +$(makeFieldLabelsNoPrefix ''EmbedFooter) + +$(deriveTextShow ''EmbedImage) +$(makeFieldLabelsNoPrefix ''EmbedImage) + +$(deriveTextShow ''EmbedThumbnail) +$(makeFieldLabelsNoPrefix ''EmbedThumbnail) + +$(deriveTextShow ''EmbedVideo) +$(makeFieldLabelsNoPrefix ''EmbedVideo) + +$(deriveTextShow ''EmbedProvider) +$(makeFieldLabelsNoPrefix ''EmbedProvider) + +$(deriveTextShow ''EmbedAuthor) +$(makeFieldLabelsNoPrefix ''EmbedAuthor) + +$(deriveTextShow ''EmbedField) +$(makeFieldLabelsNoPrefix ''EmbedField) + +instance Semigroup EmbedFooter where + l <> r = + l + & #text + %~ (<> (r ^. #text)) + & #iconUrl + %~ getLast + . (<> Last (r ^. #iconUrl)) + . Last + & #proxyIconUrl + %~ getLast + . (<> Last (r ^. #proxyIconUrl)) + . Last + +instance Semigroup Embed where + l <> r = + l + & #title + %~ (<> (r ^. #title)) + & #type_ + %~ getLast + . (<> Last (r ^. #type_)) + . Last + & #description + %~ (<> (r ^. #description)) + & #url + %~ getLast + . (<> Last (r ^. #url)) + . Last + & #timestamp + %~ getLast + . (<> Last (r ^. #timestamp)) + . Last + & #color + %~ getLast + . (<> Last (r ^. #color)) + . Last + & #footer + %~ (<> (r ^. #footer)) + & #image + %~ getLast + . (<> Last (r ^. #image)) + . Last + & #thumbnail + %~ getLast + . (<> Last (r ^. #thumbnail)) + . Last + & #video + %~ getLast + . (<> Last (r ^. #video)) + . Last + & #provider + %~ getLast + . (<> Last (r ^. #provider)) + . Last + & #author + %~ getLast + . (<> Last (r ^. #author)) + . Last + & #fields + %~ (<> (r ^. #fields)) + +instance Monoid Embed where + mempty = def diff --git a/Calamity/Types/Model/Channel/Group.hs b/Calamity/Types/Model/Channel/Group.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Group.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A Group Group channel +module Calamity.Types.Model.Channel.Group (GroupChannel (..)) where + +import {-# SOURCE #-} Calamity.Types.Model.Channel +import {-# SOURCE #-} Calamity.Types.Model.Channel.Message +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Time +import Optics.TH +import TextShow qualified + +data GroupChannel = GroupChannel + { id :: Snowflake GroupChannel + , ownerID :: Snowflake User + , lastMessageID :: Maybe (Snowflake Message) + , lastPinTimestamp :: Maybe UTCTime + , icon :: Maybe Text + , recipients :: [User] + , name :: Text + } + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow GroupChannel + deriving (HasID GroupChannel) via HasIDField "id" GroupChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" GroupChannel + deriving (HasID User) via HasIDField "ownerID" GroupChannel + +$(makeFieldLabelsNoPrefix ''GroupChannel) + +instance Aeson.FromJSON GroupChannel where + parseJSON = Aeson.withObject "GroupChannel" $ \v -> + GroupChannel + <$> v .: "id" + <*> v .: "owner_id" + <*> v .:? "last_message_id" + <*> v .:? "last_pin_timestamp" + <*> v .:? "icon" + <*> v .: "recipients" + <*> v .: "name" diff --git a/Calamity/Types/Model/Channel/Guild.hs b/Calamity/Types/Model/Channel/Guild.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Guild.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | The generic guild channel type +module Calamity.Types.Model.Channel.Guild ( + GuildChannel (..), + module Calamity.Types.Model.Channel.Guild.Category, + module Calamity.Types.Model.Channel.Guild.Text, + module Calamity.Types.Model.Channel.Guild.Voice, +) where + +import {-# SOURCE #-} Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.ChannelType +import Calamity.Types.Model.Channel.Guild.Category +import Calamity.Types.Model.Channel.Guild.Text +import Calamity.Types.Model.Channel.Guild.Voice +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Snowflake +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Optics ((^.)) +import Optics.TH +import TextShow.TH + +data GuildChannel + = GuildTextChannel TextChannel + | GuildVoiceChannel VoiceChannel + | GuildCategory Category + | OtherGuildChannel (Snowflake Guild) (Snowflake GuildChannel) -- TODO + deriving (Show, Eq) + +instance Aeson.FromJSON GuildChannel where + parseJSON = Aeson.withObject "GuildChannel" $ \v -> do + type_ <- v .: "type" + + case type_ of + GuildTextType -> GuildTextChannel <$> Aeson.parseJSON (Aeson.Object v) + GuildVoiceType -> GuildVoiceChannel <$> Aeson.parseJSON (Aeson.Object v) + GuildCategoryType -> GuildCategory <$> Aeson.parseJSON (Aeson.Object v) + _typ -> do + id_ <- v .: "id" + guildID <- v .: "guild_id" + pure $ OtherGuildChannel guildID id_ + +instance HasID GuildChannel GuildChannel where + getID (GuildTextChannel a) = coerceSnowflake $ a ^. #id + getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. #id + getID (GuildCategory a) = coerceSnowflake $ a ^. #id + getID (OtherGuildChannel _ a) = a + +instance HasID Channel GuildChannel where + getID = coerceSnowflake . getID @GuildChannel + +instance HasID Guild GuildChannel where + getID (GuildTextChannel a) = coerceSnowflake $ a ^. #guildID + getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. #guildID + getID (GuildCategory a) = coerceSnowflake $ a ^. #guildID + getID (OtherGuildChannel a _) = a + +$(deriveTextShow ''GuildChannel) +$(makeFieldLabelsNoPrefix ''GuildChannel) diff --git a/Calamity/Types/Model/Channel/Guild/Category.hs b/Calamity/Types/Model/Channel/Guild/Category.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Guild/Category.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Calamity.Types.Model.Channel.Guild.Category (Category (..)) where + +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import {-# SOURCE #-} Calamity.Types.Model.Channel +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data Category = Category + { id :: Snowflake Category + , permissionOverwrites :: SnowflakeMap Overwrite + , name :: Text + , nsfw :: Bool + , position :: Int + , guildID :: Snowflake Guild + } + deriving (Show, Eq) + deriving (HasID Category) via HasIDField "id" Category + deriving (HasID Channel) via HasIDFieldCoerce' "id" Category + +instance Aeson.FromJSON Category where + parseJSON = Aeson.withObject "Category" $ \v -> + Category + <$> v .: "id" + <*> v .: "permission_overwrites" + <*> v .: "name" + <*> v .:? "nsfw" .!= False + <*> v .: "position" + <*> v .: "guild_id" + +$(deriveTextShow ''Category) +$(makeFieldLabelsNoPrefix ''Category) diff --git a/Calamity/Types/Model/Channel/Guild/Text.hs b/Calamity/Types/Model/Channel/Guild/Text.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Guild/Text.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Calamity.Types.Model.Channel.Guild.Text (TextChannel (..)) where + +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import {-# SOURCE #-} Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.Guild.Category +import Calamity.Types.Model.Channel.Message +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Time +import Optics.TH +import TextShow qualified + +data TextChannel = TextChannel + { id :: Snowflake TextChannel + , guildID :: Snowflake Guild + , position :: Int + , permissionOverwrites :: SnowflakeMap Overwrite + , name :: Text + , topic :: Maybe Text + , nsfw :: Bool + , lastMessageID :: Maybe (Snowflake Message) + , lastPinTimestamp :: Maybe UTCTime + , rateLimitPerUser :: Maybe Int + , parentID :: Maybe (Snowflake Category) + } + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow TextChannel + deriving (HasID TextChannel) via HasIDField "id" TextChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" TextChannel + deriving (HasID Guild) via HasIDField "guildID" TextChannel + +instance Aeson.FromJSON TextChannel where + parseJSON = Aeson.withObject "TextChannel" $ \v -> + TextChannel + <$> v .: "id" + <*> v .: "guild_id" + <*> v .: "position" + <*> v .: "permission_overwrites" + <*> v .: "name" + <*> v .: "topic" + <*> v .:? "nsfw" .!= False + <*> v .:? "last_message_id" + <*> v .:? "last_pin_timestamp" + <*> v .:? "rate_limit_per_user" + <*> v .:? "parent_id" + +$(makeFieldLabelsNoPrefix ''TextChannel) diff --git a/Calamity/Types/Model/Channel/Guild/Voice.hs b/Calamity/Types/Model/Channel/Guild/Voice.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Guild/Voice.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Voice channels +module Calamity.Types.Model.Channel.Guild.Voice (VoiceChannel (..)) where + +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import {-# SOURCE #-} Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.Guild.Category +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data VoiceChannel = VoiceChannel + { id :: Snowflake VoiceChannel + , guildID :: Snowflake Guild + , position :: Int + , permissionOverwrites :: SnowflakeMap Overwrite + , name :: Text + , bitrate :: Int + , userLimit :: Int + , parentID :: Maybe (Snowflake Category) + } + deriving (Show, Eq) + deriving (HasID VoiceChannel) via HasIDField "id" VoiceChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" VoiceChannel + deriving (HasID Guild) via HasIDField "guildID" VoiceChannel + +instance Aeson.FromJSON VoiceChannel where + parseJSON = Aeson.withObject "TextChannel" $ \v -> + VoiceChannel + <$> v .: "id" + <*> v .: "guild_id" + <*> v .: "position" + <*> v .: "permission_overwrites" + <*> v .: "name" + <*> v .: "bitrate" + <*> v .: "user_limit" + <*> v .:? "parent_id" + +$(deriveTextShow ''VoiceChannel) +$(makeFieldLabelsNoPrefix ''VoiceChannel) diff --git a/Calamity/Types/Model/Channel/Message.hs b/Calamity/Types/Model/Channel/Message.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Message.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A message from a channel +module Calamity.Types.Model.Channel.Message ( + Message (..), + MessageAuthor (..), + MessageAuthorWebhook (..), + ChannelMention (..), + MessageType (..), + MessageReference (..), + Partial (PartialMessage), +) where + +import Calamity.Internal.Utils (AesonVector (..), CalamityToJSON (..), CalamityToJSON' (..), (.=), (.?=)) +import {-# SOURCE #-} Calamity.Types.Model.Channel +import Calamity.Types.Model.Channel.Attachment +import Calamity.Types.Model.Channel.ChannelType (ChannelType) +import Calamity.Types.Model.Channel.Component +import Calamity.Types.Model.Channel.Embed +import Calamity.Types.Model.Channel.Reaction +import Calamity.Types.Model.Channel.Webhook +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Maybe (isJust) +import Data.Scientific +import Data.Text (Text) +import Data.Time +import Data.Vector.Unboxing qualified as UV +import Data.Word (Word64) +import Optics.TH +import TextShow qualified +import TextShow.TH + +data MessageAuthorWebhook = MessageAuthorWebhook + { id :: Snowflake Webhook + , username :: Text + , avatar :: Maybe Text + } + deriving (Show) + deriving (HasID Webhook) via HasIDField "id" MessageAuthorWebhook + +data MessageAuthor + = User' User + | Webhook' MessageAuthorWebhook + deriving (Show) + +instance HasID User MessageAuthor where + getID (User' u) = getID u + getID (Webhook' MessageAuthorWebhook {id}) = coerceSnowflake id + +data ChannelMention = ChannelMention + { id :: Snowflake Channel + , guildID :: Snowflake Guild + , type_ :: ChannelType + , name :: Text + } + deriving (Show) + deriving (HasID Channel) via HasIDField "id" ChannelMention + +instance Aeson.FromJSON ChannelMention where + parseJSON = Aeson.withObject "Message.ChannelMention" $ \v -> + ChannelMention + <$> v .: "id" + <*> v .: "guild_id" + <*> v .: "type" + <*> v .: "name" + +data Message = Message + { id :: Snowflake Message + , channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + , author :: MessageAuthor + , content :: Text + , timestamp :: UTCTime + , editedTimestamp :: Maybe UTCTime + , tts :: Bool + , mentionEveryone :: Bool + , mentions :: [User] + , mentionRoles :: UV.Vector (Snowflake Role) + , mentionChannels :: [ChannelMention] + , attachments :: [Attachment] + , embeds :: [Embed] + , reactions :: [Reaction] + , nonce :: Maybe Aeson.Value + , pinned :: Bool + , webhookID :: Maybe (Snowflake Webhook) + , type_ :: MessageType + , activity :: Maybe Aeson.Object + , application :: Maybe Aeson.Object + , messageReference :: Maybe MessageReference + , flags :: Word64 + , referencedMessage :: Maybe Message + , interaction :: Maybe Aeson.Object + , components :: [Component] + } + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Message + deriving (HasID Message) via HasIDField "id" Message + deriving (HasID Channel) via HasIDField "channelID" Message + deriving (HasID User) via HasIDField "author" Message + +instance Aeson.FromJSON Message where + parseJSON = Aeson.withObject "Message" $ \v -> do + webhookID <- v .:? "webhook_id" + let author = + if isJust webhookID + then + Aeson.withObject + "Message.author" + ( \v -> + Webhook' + <$> ( MessageAuthorWebhook + <$> v .: "id" + <*> v .: "username" + <*> v .:? "avatar" + ) + ) + =<< v .: "author" + else User' <$> (Aeson.parseJSON =<< (v .: "author")) + + Message + <$> v .: "id" + <*> v .: "channel_id" + <*> v .:? "guild_id" + <*> author + <*> v .: "content" + <*> v .: "timestamp" + <*> v .:? "edited_timestamp" + <*> v .: "tts" + <*> v .: "mention_everyone" + <*> v .: "mentions" + <*> (unAesonVector <$> v .: "mention_roles") + <*> v .:? "mention_channels" .!= [] + <*> v .: "attachments" + <*> v .: "embeds" + <*> v .:? "reactions" .!= [] + <*> v .:? "nonce" + <*> v .: "pinned" + <*> pure webhookID + <*> v .: "type" + <*> v .:? "activity" + <*> v .:? "application" + <*> v .:? "message_reference" + <*> v .:? "flags" .!= 0 + <*> v .:? "referenced_message" + <*> v .:? "interaction" + <*> v .:? "components" .!= [] + +data instance Partial Message = PartialMessage + { channelID :: Snowflake Channel + , guildID :: Maybe (Snowflake Guild) + } + deriving (Show) + deriving (HasID Channel) via HasIDField "channelID" (Partial Message) + +instance Aeson.FromJSON (Partial Message) where + parseJSON = Aeson.withObject "Partial Message" $ \v -> + PartialMessage + <$> v .: "channel_id" + <*> v .:? "guild_id" + +data MessageReference = MessageReference + { messageID :: Maybe (Snowflake Message) + , channelID :: Maybe (Snowflake Channel) + , guildID :: Maybe (Snowflake Guild) + , failIfNotExists :: Bool + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON MessageReference + +instance CalamityToJSON' MessageReference where + toPairs MessageReference {..} = + [ "message_id" .?= messageID + , "channel_id" .?= channelID + , "guild_id" .?= guildID + , "fail_if_not_exists" .= failIfNotExists + ] + +instance Aeson.FromJSON MessageReference where + parseJSON = Aeson.withObject "MessageReference" $ \v -> + MessageReference + <$> v .:? "message_id" + <*> v .:? "channel_id" + <*> v .:? "guild_id" + <*> v .:? "fail_if_not_exists" .!= False + +-- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L264) +data MessageType + = Default + | RecipientAdd + | RecipientRemove + | Call + | ChannelNameChange + | ChannelIconChange + | ChannelPinnedMessage + | GuildMemberJoin + | UserPremiumGuildSubscription + | UserPremiumGuildSubscriptionTier1 + | UserPremiumGuildSubscriptionTier2 + | UserPremiumGuildSubscriptionTier3 + | ChannelFollowAdd + | GuildDiscoveryDisqualified + | GuildDiscoveryRequalified + | Reply + | ApplicationCommmand + deriving (Eq, Show, Enum) + +instance Aeson.FromJSON MessageType where + parseJSON = Aeson.withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 0 -> pure Default + 1 -> pure RecipientAdd + 2 -> pure RecipientRemove + 3 -> pure Call + 4 -> pure ChannelNameChange + 5 -> pure ChannelIconChange + 6 -> pure ChannelPinnedMessage + 7 -> pure GuildMemberJoin + 8 -> pure UserPremiumGuildSubscription + 9 -> pure UserPremiumGuildSubscriptionTier1 + 10 -> pure UserPremiumGuildSubscriptionTier2 + 11 -> pure UserPremiumGuildSubscriptionTier3 + 12 -> pure ChannelFollowAdd + 14 -> pure GuildDiscoveryDisqualified + 15 -> pure GuildDiscoveryRequalified + 19 -> pure Reply + 20 -> pure ApplicationCommmand + _ -> fail $ "Invalid MessageType: " <> show n + Nothing -> fail $ "Invalid MessageType: " <> show n + +$(deriveTextShow ''MessageAuthorWebhook) +$(deriveTextShow 'PartialMessage) +$(deriveTextShow ''ChannelMention) +$(deriveTextShow ''MessageType) + +$(makeFieldLabelsNoPrefix ''MessageAuthorWebhook) +$(makeFieldLabelsNoPrefix ''ChannelMention) +$(makeFieldLabelsNoPrefix 'PartialMessage) +$(makeFieldLabelsNoPrefix ''Message) +$(makeFieldLabelsNoPrefix ''MessageReference) diff --git a/Calamity/Types/Model/Channel/Message.hs-boot b/Calamity/Types/Model/Channel/Message.hs-boot new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Message.hs-boot @@ -0,0 +1,19 @@ +-- | A message from a channel +module Calamity.Types.Model.Channel.Message + ( Message + , MessageType + , MessageReference ) where + +data Message + +instance Show Message + +data MessageType + +instance Show MessageType +instance Eq MessageType + +data MessageReference + +instance Show MessageReference +instance Eq MessageReference diff --git a/Calamity/Types/Model/Channel/Reaction.hs b/Calamity/Types/Model/Channel/Reaction.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Reaction.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Message reactions +module Calamity.Types.Model.Channel.Reaction (Reaction (..)) where + +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (toPairs), (.=)) +import Calamity.Types.Model.Guild.Emoji +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Optics.TH +import TextShow.TH + +data Reaction = Reaction + { count :: Integer + , me :: Bool + , emoji :: RawEmoji + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON Reaction + +instance CalamityToJSON' Reaction where + toPairs Reaction {..} = + [ "count" .= count + , "me" .= me + , "emoj" .= emoji + ] + +instance Aeson.FromJSON Reaction where + parseJSON = Aeson.withObject "Reaction" $ \v -> + Reaction + <$> v .: "count" + <*> v .: "me" + <*> v .: "emoji" + +$(deriveTextShow ''Reaction) +$(makeFieldLabelsNoPrefix ''Reaction) diff --git a/Calamity/Types/Model/Channel/UpdatedMessage.hs b/Calamity/Types/Model/Channel/UpdatedMessage.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/UpdatedMessage.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Updated messages +module Calamity.Types.Model.Channel.UpdatedMessage ( + UpdatedMessage (..), +) where + +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:!), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Time +import Data.Vector.Unboxing qualified as UV +import Data.Word +import Optics.TH +import TextShow qualified + +data UpdatedMessage = UpdatedMessage + { id :: Snowflake Message + , channelID :: Snowflake Channel + , content :: Maybe Text + , editedTimestamp :: Maybe (MaybeNull UTCTime) + , tts :: Maybe Bool + , mentionEveryone :: Maybe Bool + , mentions :: Maybe [User] + , mentionRoles :: Maybe (UV.Vector (Snowflake Role)) + , mentionChannels :: Maybe [ChannelMention] + , attachments :: Maybe [Attachment] + , embeds :: Maybe [Embed] + , reactions :: Maybe [Reaction] + , pinned :: Maybe Bool + , type_ :: Maybe MessageType + , activity :: Maybe (MaybeNull Aeson.Object) + , application :: Maybe (MaybeNull Aeson.Object) + , messageReference :: Maybe (MaybeNull MessageReference) + , flags :: Maybe Word64 + , referencedMessage :: Maybe (MaybeNull Message) + , interaction :: Maybe (MaybeNull Aeson.Object) + , components :: Maybe [Component] + } + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow UpdatedMessage + deriving (HasID Message) via HasIDField "id" UpdatedMessage + deriving (HasID Channel) via HasIDField "channelID" UpdatedMessage + +instance Aeson.FromJSON UpdatedMessage where + parseJSON = Aeson.withObject "UpdatedMessage" $ \v -> + UpdatedMessage + <$> v .: "id" + <*> v .: "channel_id" + <*> v .:? "content" + <*> v .:! "edited_timestamp" + <*> v .:? "tts" + <*> v .:? "mention_everyone" + <*> v .:? "mentions" + <*> (fmap unAesonVector <$> v .:? "mention_roles") + <*> v .:? "mention_channels" + <*> v .:? "attachments" + <*> v .:? "embeds" + <*> v .:? "reactions" + <*> v .:? "pinned" + <*> v .:? "type" + <*> v .:! "activity" + <*> v .:! "application" + <*> v .:! "message_reference" + <*> v .:? "flags" + <*> v .:! "referenced_message" + <*> v .:! "interaction" + <*> v .:? "components" + +$(makeFieldLabelsNoPrefix ''UpdatedMessage) diff --git a/Calamity/Types/Model/Channel/Webhook.hs b/Calamity/Types/Model/Channel/Webhook.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Channel/Webhook.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Channel webhooks +module Calamity.Types.Model.Channel.Webhook (Webhook (..)) where + +import {-# SOURCE #-} Calamity.Types.Model.Channel +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data Webhook = Webhook + { id :: Snowflake Webhook + , type_ :: Integer + , guildID :: Maybe (Snowflake Guild) + , channelID :: Maybe (Snowflake Channel) + , user :: Maybe (Snowflake User) + , name :: Text + , avatar :: Text + , token :: Maybe Text + } + deriving (Eq, Show) + deriving (HasID Webhook) via HasIDField "id" Webhook + +instance Aeson.FromJSON Webhook where + parseJSON = Aeson.withObject "Webhook" $ \v -> do + user <- v .:? "user" + userID <- traverse (.: "id") user + + Webhook + <$> v .: "id" + <*> v .: "type" + <*> v .:? "guild_id" + <*> v .:? "channel_id" + <*> pure userID + <*> v .: "name" + <*> v .: "avatar" + <*> v .:? "token" + +$(deriveTextShow ''Webhook) +$(makeFieldLabelsNoPrefix ''Webhook) diff --git a/Calamity/Types/Model/Guild.hs b/Calamity/Types/Model/Guild.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild.hs @@ -0,0 +1,24 @@ +-- | Discord Guilds +module Calamity.Types.Model.Guild ( + module Calamity.Types.Model.Guild.AuditLog, + module Calamity.Types.Model.Guild.Ban, + module Calamity.Types.Model.Guild.Emoji, + module Calamity.Types.Model.Guild.Guild, + module Calamity.Types.Model.Guild.Member, + module Calamity.Types.Model.Guild.Overwrite, + module Calamity.Types.Model.Guild.Invite, + module Calamity.Types.Model.Guild.Role, + module Calamity.Types.Model.Guild.UnavailableGuild, + module Calamity.Types.Model.Guild.Permissions, +) where + +import Calamity.Types.Model.Guild.AuditLog +import Calamity.Types.Model.Guild.Ban +import Calamity.Types.Model.Guild.Emoji +import Calamity.Types.Model.Guild.Guild hiding (UpdatedGuild (..)) +import Calamity.Types.Model.Guild.Invite +import Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.Guild.UnavailableGuild diff --git a/Calamity/Types/Model/Guild/AuditLog.hs b/Calamity/Types/Model/Guild/AuditLog.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/AuditLog.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Audit Log models +module Calamity.Types.Model.Guild.AuditLog ( + AuditLog (..), + AuditLogEntry (..), + AuditLogEntryInfo (..), + AuditLogChange (..), + AuditLogAction (..), +) where + +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Scientific +import Data.Text (Text) +import Optics.TH +import TextShow qualified +import TextShow.TH + +data AuditLog = AuditLog + { webhooks :: SnowflakeMap Webhook + , users :: SnowflakeMap User + , auditLogEntries :: SnowflakeMap AuditLogEntry + } + deriving (Show) + +data AuditLogEntry = AuditLogEntry + { targetID :: Maybe (Snowflake ()) + , changes :: [AuditLogChange] + , userID :: Snowflake User + , id :: Snowflake AuditLogEntry + , actionType :: AuditLogAction + , options :: Maybe AuditLogEntryInfo + , reason :: Maybe Text + } + deriving (Show) + deriving (HasID User) via HasIDField "userID" AuditLogEntry + deriving (HasID AuditLogEntry) via HasIDField "id" AuditLogEntry + +instance Aeson.FromJSON AuditLogEntry where + parseJSON = Aeson.withObject "AuditLogEntry" $ \v -> + AuditLogEntry + <$> v .:? "target_id" + <*> v .: "changes" + <*> v .: "user_id" + <*> v .: "id" + <*> v .: "action_type" + <*> v .: "options" + <*> v .:? "reason" + +data AuditLogEntryInfo = AuditLogEntryInfo + { deleteMemberDays :: Maybe Text + , membersRemoved :: Maybe Text + , channelID :: Maybe (Snowflake Channel) + , messageID :: Maybe (Snowflake Message) + , count :: Maybe Text + , id :: Maybe (Snowflake ()) + , type_ :: Maybe Text + , roleName :: Maybe Text + } + deriving (Show) + +instance Aeson.FromJSON AuditLogEntryInfo where + parseJSON = Aeson.withObject "AudotLogEntryInfo" $ \v -> + AuditLogEntryInfo + <$> v .:? "delete_member_days" + <*> v .:? "members_removed" + <*> v .:? "channel_id" + <*> v .:? "message_id" + <*> v .:? "count" + <*> v .:? "id" + <*> v .:? "type" + <*> v .:? "role_name" + +data AuditLogChange = AuditLogChange + { newValue :: Maybe Aeson.Value + , oldValue :: Maybe Aeson.Value + , key :: Text + } + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow AuditLogChange + +instance Aeson.FromJSON AuditLogChange where + parseJSON = Aeson.withObject "AudotLogChange" $ \v -> + AuditLogChange + <$> v .:? "new_value" + <*> v .:? "old_value" + <*> v .: "key" + +data AuditLogAction + = GUILD_UPDATE + | CHANNEL_CREATE + | CHANNEL_UPDATE + | CHANNEL_DELETE + | CHANNEL_OVERWRITE_CREATE + | CHANNEL_OVERWRITE_UPDATE + | CHANNEL_OVERWRITE_DELETE + | MEMBER_KICK + | MEMBER_PRUNE + | MEMBER_BAN_ADD + | MEMBER_BAN_REMOVE + | MEMBER_UPDATE + | MEMBER_ROLE_UPDATE + | MEMBER_MOVE + | MEMBER_DISCONNECT + | BOT_ADD + | ROLE_CREATE + | ROLE_UPDATE + | ROLE_DELETE + | INVITE_CREATE + | INVITE_UPDATE + | INVITE_DELETE + | WEBHOOK_CREATE + | WEBHOOK_UPDATE + | WEBHOOK_DELETE + | EMOJI_CREATE + | EMOJI_UPDATE + | EMOJI_DELETE + | MESSAGE_DELETE + | MESSAGE_BULK_DELETE + | MESSAGE_PIN + | MESSAGE_UNPIN + | INTEGRATION_CREATE + | INTEGRATION_UPDATE + | INTEGRATION_DELETE + deriving (Show) + +instance Enum AuditLogAction where + toEnum v = case v of + 1 -> GUILD_UPDATE + 10 -> CHANNEL_CREATE + 11 -> CHANNEL_UPDATE + 12 -> CHANNEL_DELETE + 13 -> CHANNEL_OVERWRITE_CREATE + 14 -> CHANNEL_OVERWRITE_UPDATE + 15 -> CHANNEL_OVERWRITE_DELETE + 20 -> MEMBER_KICK + 21 -> MEMBER_PRUNE + 22 -> MEMBER_BAN_ADD + 23 -> MEMBER_BAN_REMOVE + 24 -> MEMBER_UPDATE + 25 -> MEMBER_ROLE_UPDATE + 26 -> MEMBER_MOVE + 27 -> MEMBER_DISCONNECT + 28 -> BOT_ADD + 30 -> ROLE_CREATE + 31 -> ROLE_UPDATE + 32 -> ROLE_DELETE + 40 -> INVITE_CREATE + 41 -> INVITE_UPDATE + 42 -> INVITE_DELETE + 50 -> WEBHOOK_CREATE + 51 -> WEBHOOK_UPDATE + 52 -> WEBHOOK_DELETE + 60 -> EMOJI_CREATE + 61 -> EMOJI_UPDATE + 62 -> EMOJI_DELETE + 72 -> MESSAGE_DELETE + 73 -> MESSAGE_BULK_DELETE + 74 -> MESSAGE_PIN + 75 -> MESSAGE_UNPIN + 80 -> INTEGRATION_CREATE + 81 -> INTEGRATION_UPDATE + 82 -> INTEGRATION_DELETE + _ -> error $ "Invalid AuditLogAction: " <> show v + + fromEnum v = case v of + GUILD_UPDATE -> 1 + CHANNEL_CREATE -> 10 + CHANNEL_UPDATE -> 11 + CHANNEL_DELETE -> 12 + CHANNEL_OVERWRITE_CREATE -> 13 + CHANNEL_OVERWRITE_UPDATE -> 14 + CHANNEL_OVERWRITE_DELETE -> 15 + MEMBER_KICK -> 20 + MEMBER_PRUNE -> 21 + MEMBER_BAN_ADD -> 22 + MEMBER_BAN_REMOVE -> 23 + MEMBER_UPDATE -> 24 + MEMBER_ROLE_UPDATE -> 25 + MEMBER_MOVE -> 26 + MEMBER_DISCONNECT -> 27 + BOT_ADD -> 28 + ROLE_CREATE -> 30 + ROLE_UPDATE -> 31 + ROLE_DELETE -> 32 + INVITE_CREATE -> 40 + INVITE_UPDATE -> 41 + INVITE_DELETE -> 42 + WEBHOOK_CREATE -> 50 + WEBHOOK_UPDATE -> 51 + WEBHOOK_DELETE -> 52 + EMOJI_CREATE -> 60 + EMOJI_UPDATE -> 61 + EMOJI_DELETE -> 62 + MESSAGE_DELETE -> 72 + MESSAGE_BULK_DELETE -> 73 + MESSAGE_PIN -> 74 + MESSAGE_UNPIN -> 75 + INTEGRATION_CREATE -> 80 + INTEGRATION_UPDATE -> 81 + INTEGRATION_DELETE -> 82 + +instance Aeson.FromJSON AuditLogAction where + parseJSON = Aeson.withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of -- no safe toEnum :S + 1 -> pure GUILD_UPDATE + 10 -> pure CHANNEL_CREATE + 11 -> pure CHANNEL_UPDATE + 12 -> pure CHANNEL_DELETE + 13 -> pure CHANNEL_OVERWRITE_CREATE + 14 -> pure CHANNEL_OVERWRITE_UPDATE + 15 -> pure CHANNEL_OVERWRITE_DELETE + 20 -> pure MEMBER_KICK + 21 -> pure MEMBER_PRUNE + 22 -> pure MEMBER_BAN_ADD + 23 -> pure MEMBER_BAN_REMOVE + 24 -> pure MEMBER_UPDATE + 25 -> pure MEMBER_ROLE_UPDATE + 26 -> pure MEMBER_MOVE + 27 -> pure MEMBER_DISCONNECT + 28 -> pure BOT_ADD + 30 -> pure ROLE_CREATE + 31 -> pure ROLE_UPDATE + 32 -> pure ROLE_DELETE + 40 -> pure INVITE_CREATE + 41 -> pure INVITE_UPDATE + 42 -> pure INVITE_DELETE + 50 -> pure WEBHOOK_CREATE + 51 -> pure WEBHOOK_UPDATE + 52 -> pure WEBHOOK_DELETE + 60 -> pure EMOJI_CREATE + 61 -> pure EMOJI_UPDATE + 62 -> pure EMOJI_DELETE + 72 -> pure MESSAGE_DELETE + 73 -> pure MESSAGE_BULK_DELETE + 74 -> pure MESSAGE_PIN + 75 -> pure MESSAGE_UNPIN + 80 -> pure INTEGRATION_CREATE + 81 -> pure INTEGRATION_UPDATE + 82 -> pure INTEGRATION_DELETE + _ -> fail $ "Invalid AuditLogAction: " <> show n + Nothing -> fail $ "Invalid AuditLogAction: " <> show n + +instance Aeson.ToJSON AuditLogAction where + toJSON = Aeson.toJSON @Int . fromEnum + toEncoding = Aeson.toEncoding @Int . fromEnum + +$(deriveTextShow ''AuditLogAction) +$(deriveTextShow ''AuditLogEntryInfo) +$(deriveTextShow ''AuditLogEntry) +$(deriveTextShow ''AuditLog) + +$(makeFieldLabelsNoPrefix ''AuditLog) +$(makeFieldLabelsNoPrefix ''AuditLogEntry) +$(makeFieldLabelsNoPrefix ''AuditLogEntryInfo) +$(makeFieldLabelsNoPrefix ''AuditLogChange) diff --git a/Calamity/Types/Model/Guild/Ban.hs b/Calamity/Types/Model/Guild/Ban.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Ban.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Guild ban objects +module Calamity.Types.Model.Guild.Ban (BanData (..)) where + +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Optics.TH +import TextShow.TH + +data BanData = BanData + { guildID :: Snowflake Guild + , user :: User + } + deriving (Show) + deriving (HasID Guild) via HasIDField "guildID" BanData + deriving (HasID User) via HasIDField "user" BanData + +instance Aeson.FromJSON BanData where + parseJSON = Aeson.withObject "BanData" $ \v -> + BanData + <$> v .: "guild_id" + <*> v .: "user" + +$(deriveTextShow ''BanData) +$(makeFieldLabelsNoPrefix ''BanData) diff --git a/Calamity/Types/Model/Guild/Emoji.hs b/Calamity/Types/Model/Guild/Emoji.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Emoji.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Discord emojis +module Calamity.Types.Model.Guild.Emoji ( + Emoji (..), + Partial (PartialEmoji), + RawEmoji (..), + emojiAsRawEmoji, +) where + +import Calamity.Internal.Utils ( + AesonVector (unAesonVector), + CalamityToJSON (..), + CalamityToJSON' (..), + (.=), + ) +import Calamity.Types.CDNAsset (CDNAsset (..)) +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 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 TextShow qualified + +data Emoji = Emoji + { id :: Snowflake Emoji + , name :: T.Text + , roles :: Vector (Snowflake Role) + , user :: Maybe User + , requireColons :: Bool + , managed :: Bool + , animated :: Bool + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Emoji + deriving (HasID Emoji) via HasIDField "id" Emoji + +instance Aeson.FromJSON Emoji where + parseJSON = Aeson.withObject "Emoji" $ \v -> + Emoji + <$> v .: "id" + <*> v .: "name" + <*> (fmap unAesonVector <$> v .:? "roles") .!= mempty + <*> v .:? "user" + <*> v .:? "require_colons" .!= False + <*> v .:? "managed" .!= False + <*> v .:? "animated" .!= False + +instance CDNAsset Emoji where + assetURL Emoji {id, animated} = + cdnURL /: "emojis" /: (showt id <> if animated then ".gif" else ".png") + +emojiAsRawEmoji :: Emoji -> RawEmoji +emojiAsRawEmoji Emoji {id, name, animated} = CustomEmoji $ PartialEmoji id name animated + +data instance Partial Emoji = PartialEmoji + { id :: Snowflake Emoji + , name :: T.Text + , animated :: Bool + } + deriving (Eq) + deriving (HasID Emoji) via HasIDField "id" (Partial Emoji) + deriving (Aeson.ToJSON) via CalamityToJSON (Partial Emoji) + +instance Aeson.FromJSON (Partial Emoji) where + parseJSON = Aeson.withObject "Partial Emoji" $ \v -> + PartialEmoji + <$> v .: "id" + <*> v .: "name" + <*> v .:? "animated" .!= False + +instance CalamityToJSON' (Partial Emoji) where + toPairs PartialEmoji {..} = + [ "id" .= id + , "name" .= name + , "animated" .= animated + ] + +instance Show (Partial Emoji) where + show PartialEmoji {id, name, animated} = + "<" <> a <> ":" <> T.unpack name <> ":" <> show id <> ">" + where + a = if animated then "a" else "" + +instance TextShow.TextShow (Partial Emoji) where + showb PartialEmoji {id, name, animated} = + "<" <> a <> ":" <> TextShow.fromText name <> ":" <> TextShow.showb id <> ">" + where + a = if animated then "a" else "" + +data RawEmoji + = UnicodeEmoji T.Text + | CustomEmoji (Partial Emoji) + deriving (Eq) + +instance Show RawEmoji where + show (UnicodeEmoji v) = T.unpack v + show (CustomEmoji p) = show p + +instance TextShow.TextShow RawEmoji where + showb (UnicodeEmoji v) = TextShow.fromText v + showb (CustomEmoji p) = TextShow.showb p + +instance Aeson.ToJSON RawEmoji where + toJSON (CustomEmoji e) = Aeson.toJSON e + toJSON (UnicodeEmoji s) = Aeson.object ["name" Aeson..= s, "id" Aeson..= Nothing @()] + toEncoding (CustomEmoji e) = Aeson.toEncoding e + toEncoding (UnicodeEmoji s) = Aeson.pairs . mconcat $ ["name" Aeson..= s, "id" Aeson..= Nothing @()] + +instance Aeson.FromJSON RawEmoji where + parseJSON = Aeson.withObject "RawEmoji" $ \v -> do + m_id :: Maybe (Snowflake Emoji) <- v .:? "id" + anim <- v .:? "animated" .!= False + name :: T.Text <- v .: "name" + + pure $ case m_id of + Just id -> CustomEmoji $ PartialEmoji id name anim + Nothing -> UnicodeEmoji name + +$(makeFieldLabelsNoPrefix ''Emoji) +$(makeFieldLabelsNoPrefix 'PartialEmoji) +$(makeFieldLabelsNoPrefix ''RawEmoji) diff --git a/Calamity/Types/Model/Guild/Guild.hs b/Calamity/Types/Model/Guild/Guild.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Guild.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Discord Guilds +module Calamity.Types.Model.Guild.Guild ( + Guild (..), + GuildIcon (..), + GuildSplash (..), + GuildDiscoverySplash (..), + GuildBanner (..), + Partial (PartialGuild), + UpdatedGuild (..), +) where + +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import Calamity.Internal.SnowflakeMap qualified as SM +import Calamity.Internal.Utils (CalamityToJSON (..), CalamityToJSON' (..), (.=)) +import Calamity.Types.CDNAsset (CDNAsset (..)) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Emoji +import Calamity.Types.Model.Guild.Member +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.Presence.Presence +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice.VoiceState +import Calamity.Types.Snowflake +import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as LH +import Data.Maybe +import Data.Text qualified as T +import Data.Time +import Data.Word +import Network.HTTP.Req ((/:), (/~)) +import Optics +import TextShow qualified +import TextShow.TH (deriveTextShow) + +data GuildIcon = GuildIcon + { guildID :: Snowflake Guild + , hash :: T.Text + } + deriving (Show, Eq) + +instance CDNAsset GuildIcon where + assetURL GuildIcon {hash, guildID} = + cdnURL /: "icons" /~ guildID /: assetHashFile hash + +data GuildSplash = GuildSplash + { guildID :: Snowflake Guild + , hash :: T.Text + } + deriving (Show, Eq) + +instance CDNAsset GuildSplash where + assetURL GuildSplash {hash, guildID} = + cdnURL /: "splashes" /~ guildID /: assetHashFile hash + +data GuildDiscoverySplash = GuildDiscoverySplash + { guildID :: Snowflake Guild + , hash :: T.Text + } + deriving (Show, Eq) + +instance CDNAsset GuildDiscoverySplash where + assetURL GuildDiscoverySplash {hash, guildID} = + cdnURL /: "discovery-splashes" /~ guildID /: assetHashFile hash + +data GuildBanner = GuildBanner + { guildID :: Snowflake Guild + , hash :: T.Text + } + deriving (Show, Eq) + +instance CDNAsset GuildBanner where + assetURL GuildBanner {hash, guildID} = + cdnURL /: "banners" /~ guildID /: assetHashFile hash + +data Guild = Guild + { id :: Snowflake Guild + , name :: T.Text + , icon :: Maybe GuildIcon + , splash :: Maybe GuildSplash + , discoverySplash :: Maybe GuildSplash + , banner :: Maybe GuildBanner + , owner :: Maybe Bool + , ownerID :: Snowflake User + , permissions :: Word64 + , afkChannelID :: Maybe (Snowflake GuildChannel) + , afkTimeout :: Int + , embedEnabled :: Bool + , embedChannelID :: Maybe (Snowflake GuildChannel) + , verificationLevel :: Int + , defaultMessageNotifications :: Int + , explicitContentFilter :: Int + , roles :: SnowflakeMap Role + , emojis :: SnowflakeMap Emoji + , features :: [T.Text] + , mfaLevel :: Int + , applicationID :: Maybe (Snowflake User) + , widgetEnabled :: Bool + , widgetChannelID :: Maybe (Snowflake GuildChannel) + , systemChannelID :: Maybe (Snowflake GuildChannel) + , -- NOTE: Below are only sent on GuildCreate + joinedAt :: Maybe UTCTime + , large :: Bool + , unavailable :: Bool + , memberCount :: Int + , voiceStates :: [VoiceState] + , members :: SnowflakeMap Member + , channels :: SnowflakeMap GuildChannel + , presences :: HashMap (Snowflake User) Presence + , preferredLocale :: T.Text + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Guild + deriving (HasID Guild) via HasIDField "id" Guild + +instance Aeson.FromJSON Guild where + parseJSON = Aeson.withObject "Guild" $ \v -> do + id <- v .: "id" + + members' <- do + members' <- v .: "members" + pure . SM.fromList . mapMaybe (Aeson.parseMaybe @Aeson.Object @Member (Aeson.parseJSON . Aeson.Object)) $ members' + + channels' <- do + channels' <- v .: "channels" + SM.fromList <$> traverse (\c -> Aeson.parseJSON $ Aeson.Object (c <> "guild_id" Aeson..= id)) channels' + + presences' <- do + presences' <- v .: "presences" + pure + . LH.fromList + . mapMaybe + ( Aeson.parseMaybe @Aeson.Object @(Snowflake User, Presence) + ( \m -> do + p <- Aeson.parseJSON $ Aeson.Object (m <> "guild_id" Aeson..= id) + pure (getID $ p ^. labelOptic @"user", p) + ) + ) + $ presences' + + icon <- (GuildIcon id <$>) <$> v .:? "icon" + splash <- (GuildSplash id <$>) <$> v .:? "splash" + discoverySplash <- (GuildSplash id <$>) <$> v .:? "discovery_splash" + banner <- (GuildBanner id <$>) <$> v .:? "banner" + + Guild id + <$> v .: "name" + <*> pure icon + <*> pure splash + <*> pure discoverySplash + <*> pure banner + <*> v .:? "owner" + <*> v .: "owner_id" + <*> v .:? "permissions" .!= 0 + <*> v .:? "afk_channel_id" + <*> v .: "afk_timeout" + <*> v .:? "embed_enabled" .!= False + <*> v .:? "embed_channel_id" + <*> v .: "verification_level" + <*> v .: "default_message_notifications" + <*> v .: "explicit_content_filter" + <*> v .: "roles" + <*> v .: "emojis" + <*> v .: "features" + <*> v .: "mfa_level" + <*> v .:? "application_id" + <*> v .:? "widget_enabled" .!= False + <*> v .:? "widget_channel_id" + <*> v .:? "system_channel_id" + <*> v .:? "joined_at" + <*> v .: "large" + <*> v .:? "unavailable" .!= False + <*> v .: "member_count" + <*> v .: "voice_states" + <*> pure members' + <*> pure channels' + <*> pure presences' + <*> v .: "preferred_locale" + +data instance Partial Guild = PartialGuild + { id :: Snowflake Guild + , name :: T.Text + } + deriving (Eq, Show) + deriving (HasID Guild) via HasIDField "id" (Partial Guild) + deriving (Aeson.ToJSON) via CalamityToJSON (Partial Guild) + +instance CalamityToJSON' (Partial Guild) where + toPairs PartialGuild {..} = + [ "id" .= id + , "name" .= name + ] + +instance Aeson.FromJSON (Partial Guild) where + parseJSON = Aeson.withObject "Partial Guild" $ \v -> + PartialGuild + <$> v .: "id" + <*> v .: "name" + +data UpdatedGuild = UpdatedGuild + { id :: Snowflake Guild + , name :: T.Text + , icon :: Maybe GuildIcon + , splash :: Maybe GuildSplash + , discoverySplash :: Maybe GuildSplash + , banner :: Maybe GuildBanner + , owner :: Maybe Bool + , ownerID :: Snowflake User + , permissions :: Maybe Word64 + , afkChannelID :: Maybe (Snowflake GuildChannel) + , afkTimeout :: Int + , embedEnabled :: Maybe Bool + , embedChannelID :: Maybe (Snowflake GuildChannel) + , verificationLevel :: Int + , defaultMessageNotifications :: Int + , explicitContentFilter :: Int + , roles :: SnowflakeMap Role + , emojis :: SnowflakeMap Emoji + , features :: [T.Text] + , mfaLevel :: Int + , applicationID :: Maybe (Snowflake User) + , widgetEnabled :: Maybe Bool + , widgetChannelID :: Maybe (Snowflake GuildChannel) + , systemChannelID :: Maybe (Snowflake GuildChannel) + , preferredLocale :: T.Text + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow UpdatedGuild + deriving (HasID Guild) via HasIDField "id" UpdatedGuild + +instance Aeson.FromJSON UpdatedGuild where + parseJSON = Aeson.withObject "Guild" $ \v -> do + id <- v .: "id" + icon <- (GuildIcon id <$>) <$> v .:? "icon" + splash <- (GuildSplash id <$>) <$> v .:? "splash" + discoverySplash <- (GuildSplash id <$>) <$> v .:? "discovery_splash" + banner <- (GuildBanner id <$>) <$> v .:? "banner" + + UpdatedGuild + <$> v .: "id" + <*> v .: "name" + <*> pure icon + <*> pure splash + <*> pure discoverySplash + <*> pure banner + <*> v .:? "owner" + <*> v .: "owner_id" + <*> v .:? "permissions" + <*> v .:? "afk_channel_id" + <*> v .: "afk_timeout" + <*> v .:? "embed_enabled" + <*> v .:? "embed_channel_id" + <*> v .: "verification_level" + <*> v .: "default_message_notifications" + <*> v .: "explicit_content_filter" + <*> v .: "roles" + <*> v .: "emojis" + <*> v .: "features" + <*> v .: "mfa_level" + <*> v .:? "application_id" + <*> v .:? "widget_enabled" + <*> v .:? "widget_channel_id" + <*> v .:? "system_channel_id" + <*> v .: "preferred_locale" + +$(deriveTextShow ''GuildIcon) +$(deriveTextShow 'PartialGuild) + +$(makeFieldLabelsNoPrefix ''Guild) +$(makeFieldLabelsNoPrefix ''GuildIcon) +$(makeFieldLabelsNoPrefix 'PartialGuild) +$(makeFieldLabelsNoPrefix ''UpdatedGuild) diff --git a/Calamity/Types/Model/Guild/Guild.hs-boot b/Calamity/Types/Model/Guild/Guild.hs-boot new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Guild.hs-boot @@ -0,0 +1,14 @@ +-- | Discord Guilds +module Calamity.Types.Model.Guild.Guild + ( Guild + , UpdatedGuild ) where + +data Guild + +instance Show Guild +instance Eq Guild + +data UpdatedGuild + +instance Show UpdatedGuild +instance Eq UpdatedGuild diff --git a/Calamity/Types/Model/Guild/Invite.hs b/Calamity/Types/Model/Guild/Invite.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Invite.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Guild invites +module Calamity.Types.Model.Guild.Invite (Invite (..)) where + +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Data.Time (UTCTime) +import Optics.TH +import TextShow qualified + +data Invite = Invite + { code :: Text + , guild :: Maybe (Partial Guild) + , channel :: Maybe (Partial Channel) + , inviter :: Maybe User + , targetUser :: Maybe User + , targetType :: Maybe Int + , approximatePresenceCount :: Maybe Int + , approximateMemberCount :: Maybe Int + , expiresAt :: Maybe UTCTime + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Invite + +instance Aeson.FromJSON Invite where + parseJSON = Aeson.withObject "Invite" $ \v -> + Invite + <$> v .: "code" + <*> v .:? "guild" + <*> v .:? "channel" + <*> v .:? "inviter" + <*> v .:? "target_user" + <*> v .:? "target_type" + <*> v .:? "approximate_presence_count" + <*> v .:? "approximate_user_count" + <*> v .:? "expires_at" + +$(makeFieldLabelsNoPrefix ''Invite) diff --git a/Calamity/Types/Model/Guild/Member.hs b/Calamity/Types/Model/Guild/Member.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Member.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Guild Members +module Calamity.Types.Model.Guild.Member (Member (..)) where + +import Calamity.Internal.IntColour +import Calamity.Internal.Utils (AesonVector (unAesonVector)) +import Calamity.Types.Model.Avatar (Avatar (..)) +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson 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 Data.Vector.Unboxing qualified as V +import Data.Word (Word64) +import Optics.TH +import TextShow qualified + +data Member = Member + { id :: Snowflake User + , username :: Text + , discriminator :: Text + , bot :: Maybe Bool + , avatar :: Avatar + , memberAvatar :: Maybe Text + , mfaEnabled :: Maybe Bool + , banner :: Maybe UserBanner + , accentColour :: Maybe (Colour Double) + , locale :: Maybe Text + , verified :: Maybe Bool + , email :: Maybe Text + , flags :: Maybe Word64 + , premiumType :: Maybe Word64 + , nick :: Maybe Text + , roles :: Vector (Snowflake Role) + , joinedAt :: UTCTime + , deaf :: Bool + , mute :: Bool + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Member + deriving (HasID Member) via HasIDFieldCoerce "id" Member User + deriving (HasID User) via HasIDField "id" Member + +instance Aeson.FromJSON Member where + parseJSON = Aeson.withObject "Member" $ \v -> do + u :: Aeson.Object <- v .: "user" + uid <- u .: "id" + avatarHash <- u .:? "avatar" + discrim <- u .: "discriminator" + discrim' <- case decimal discrim of + Right (n, _) -> pure n + Left e -> fail e + let avatar = Avatar avatarHash uid discrim' + banner <- (UserBanner uid <$>) <$> v .:? "banner" + Member + <$> pure uid + <*> u .: "username" + <*> u .: "discriminator" + <*> v .:? "bot" + <*> pure avatar + <*> v .:? "avatar" + <*> v .:? "mfa_enabled" + <*> pure banner + <*> (fmap fromIntColour <$> v .:? "accent_color") + <*> v .:? "locale" + <*> v .:? "verified" + <*> v .:? "email" + <*> v .:? "flags" + <*> v .:? "premium_type" + <*> v .:? "nick" + <*> (fmap unAesonVector <$> v .:? "roles") .!= V.empty + <*> v .: "joined_at" + <*> v .: "deaf" + <*> v .: "mute" + +$(makeFieldLabelsNoPrefix ''Member) diff --git a/Calamity/Types/Model/Guild/Member.hs-boot b/Calamity/Types/Model/Guild/Member.hs-boot new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Member.hs-boot @@ -0,0 +1,8 @@ +-- | Guild Members +module Calamity.Types.Model.Guild.Member + ( Member ) where + +data Member + +instance Show Member +instance Eq Member diff --git a/Calamity/Types/Model/Guild/Overwrite.hs b/Calamity/Types/Model/Guild/Overwrite.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Overwrite.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Permission overwrites +module Calamity.Types.Model.Guild.Overwrite (Overwrite (..)) where + +import Calamity.Internal.Utils +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Snowflake +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Optics.TH +import TextShow.TH + +data Overwrite = Overwrite + { id :: Snowflake Overwrite + , type_ :: Int + , allow :: Permissions + , deny :: Permissions + } + deriving (Eq, Show) + deriving (HasID Overwrite) via HasIDField "id" Overwrite + deriving (Aeson.ToJSON) via CalamityToJSON Overwrite + +instance CalamityToJSON' Overwrite where + toPairs Overwrite {..} = + [ "id" .= id + , "type" .= type_ + , "allow" .= allow + , "deny" .= deny + ] + +instance Aeson.FromJSON Overwrite where + parseJSON = Aeson.withObject "Overwrite" $ \v -> + Overwrite + <$> v .: "id" + <*> v .: "type" + <*> v .: "allow" + <*> v .: "deny" + +$(deriveTextShow ''Overwrite) +$(makeFieldLabelsNoPrefix ''Overwrite) diff --git a/Calamity/Types/Model/Guild/Permissions.hs b/Calamity/Types/Model/Guild/Permissions.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Permissions.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoDeriveAnyClass #-} + +-- | Guild permissions +module Calamity.Types.Model.Guild.Permissions ( + Permissions (..), + createInstantInvite, + kickMembers, + banMembers, + administrator, + manageChannels, + manageGuild, + addReactions, + viewAuditLog, + prioritySpeaker, + stream, + viewChannel, + sendMessages, + sendTtsMessages, + manageMessages, + embedLinks, + attachFiles, + readMessageHistory, + mentionEveryone, + useExternalEmojis, + viewGuildInsights, + connect, + speak, + muteMembers, + deafenMembers, + moveMembers, + useVad, + changeNickname, + manageNicknames, + manageRoles, + manageWebhooks, + manageEmojis, +) where + +import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson.Types (parseFail) +import Data.Bits (Bits (shiftL)) +import Data.Flags () +import Data.Flags.TH +import Data.Text.Read (decimal) +import Data.Word +import TextShow + +$( bitmaskWrapper + "Permissions" + ''Word64 + [] + [ ("createInstantInvite", 1 `shiftL` 0) + , ("kickMembers", 1 `shiftL` 1) + , ("banMembers", 1 `shiftL` 2) + , ("administrator", 1 `shiftL` 3) + , ("manageChannels", 1 `shiftL` 4) + , ("manageGuild", 1 `shiftL` 5) + , ("addReactions", 1 `shiftL` 6) + , ("viewAuditLog", 1 `shiftL` 7) + , ("prioritySpeaker", 1 `shiftL` 8) + , ("stream", 1 `shiftL` 9) + , ("viewChannel", 1 `shiftL` 10) + , ("sendMessages", 1 `shiftL` 11) + , ("sendTtsMessages", 1 `shiftL` 12) + , ("manageMessages", 1 `shiftL` 13) + , ("embedLinks", 1 `shiftL` 14) + , ("attachFiles", 1 `shiftL` 15) + , ("readMessageHistory", 1 `shiftL` 16) + , ("mentionEveryone", 1 `shiftL` 17) + , ("useExternalEmojis", 1 `shiftL` 18) + , ("viewGuildInsights", 1 `shiftL` 19) + , ("connect", 1 `shiftL` 20) + , ("speak", 1 `shiftL` 21) + , ("muteMembers", 1 `shiftL` 22) + , ("deafenMembers", 1 `shiftL` 23) + , ("moveMembers", 1 `shiftL` 24) + , ("useVad", 1 `shiftL` 25) + , ("changeNickname", 1 `shiftL` 26) + , ("manageNicknames", 1 `shiftL` 27) + , ("manageRoles", 1 `shiftL` 28) + , ("manageWebhooks", 1 `shiftL` 29) + , ("manageEmojis", 1 `shiftL` 30) + , ("useApplicationCommands", 1 `shiftL` 31) + , ("requestToSPeak", 1 `shiftL` 32) + , ("manageEvents", 1 `shiftL` 33) + , ("manageThreads", 1 `shiftL` 34) + , ("createPublicThreads", 1 `shiftL` 35) + , ("createPrivateThreads", 1 `shiftL` 36) + , ("useExternalStickers", 1 `shiftL` 37) + , ("sendMessagesInThreads", 1 `shiftL` 38) + , ("useEmbeddedActivities", 1 `shiftL` 39) + , ("moderateMembers", 1 `shiftL` 40) + ] + ) + +instance ToJSON Permissions where + toJSON = toJSON . showt + toEncoding = toEncoding . showt + +instance FromJSON Permissions where + parseJSON a = do + asText <- parseJSON a + case decimal asText of + Right (n, _) -> pure $ Permissions n + Left e -> parseFail e + +deriving via FromStringShow Permissions instance TextShow Permissions +deriving via Word64 instance NFData Permissions diff --git a/Calamity/Types/Model/Guild/Role.hs b/Calamity/Types/Model/Guild/Role.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/Role.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Guild roles +module Calamity.Types.Model.Guild.Role ( + Role (..), + RoleIcon (..), +) where + +import Calamity.Internal.IntColour +import Calamity.Internal.Utils +import Calamity.Types.CDNAsset (CDNAsset (..)) +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 Data.Aeson qualified as Aeson +import Data.Colour +import Data.Text (Text) +import Data.Text qualified as T +import Network.HTTP.Req ((/:), (/~)) +import Optics.TH +import TextShow qualified + +data RoleIcon = RoleIcon + { roleID :: Snowflake Role + , hash :: T.Text + } + deriving (Show, Eq) + +instance CDNAsset RoleIcon where + assetURL RoleIcon {hash, roleID} = + cdnURL /: "icons" /~ roleID /: assetHashFile hash + +data Role = Role + { id :: Snowflake Role + , name :: Text + , color :: Colour Double + , hoist :: Bool + , icon :: Maybe RoleIcon + , emoji :: Maybe RawEmoji + , position :: Int + , permissions :: Permissions + , managed :: Bool + , mentionable :: Bool + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow Role + deriving (HasID Role) via HasIDField "id" Role + deriving (Aeson.ToJSON) via CalamityToJSON Role + +instance CalamityToJSON' Role where + toPairs Role {..} = + [ "id" .= id + , "name" .= name + , "color" .= IntColour color + , "position" .= position + , "permissions" .= permissions + , "managed" .= managed + , "mentionable" .= mentionable + ] + +instance Aeson.FromJSON Role where + parseJSON = Aeson.withObject "Role" $ \v -> do + id <- v .: "id" + icon <- (RoleIcon id <$>) <$> v .: "icon" + emoji <- (UnicodeEmoji <$>) <$> v .:? "unicode_emoji" + + Role + <$> pure id + <*> v .: "name" + <*> (fromIntColour <$> v .: "color") + <*> v .: "hoist" + <*> pure icon + <*> pure emoji + <*> v .: "position" + <*> v .: "permissions" + <*> v .: "managed" + <*> v .: "mentionable" + +$(makeFieldLabelsNoPrefix ''Role) 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 new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Guild/UnavailableGuild.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Guilds that are unavailable +module Calamity.Types.Model.Guild.UnavailableGuild (UnavailableGuild (..)) where + +import Calamity.Internal.Utils +import Calamity.Types.Model.Guild.Guild +import Calamity.Types.Snowflake +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Optics.TH +import TextShow.TH + +data UnavailableGuild = UnavailableGuild + { id :: Snowflake Guild + , unavailable :: Bool + } + deriving (Eq, Show) + deriving (HasID Guild) via HasIDField "id" UnavailableGuild + deriving (Aeson.ToJSON) via CalamityToJSON UnavailableGuild + +instance CalamityToJSON' UnavailableGuild where + toPairs UnavailableGuild {..} = + [ "id" .= id + , "unavailable" .= unavailable + ] + +instance Aeson.FromJSON UnavailableGuild where + parseJSON = Aeson.withObject "UnavailableGuild" $ \v -> + UnavailableGuild + <$> v .: "id" + <*> v .:? "disabled" .!= False + +$(deriveTextShow ''UnavailableGuild) +$(makeFieldLabelsNoPrefix ''UnavailableGuild) diff --git a/Calamity/Types/Model/Interaction.hs b/Calamity/Types/Model/Interaction.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Interaction.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Discord Interactions +module Calamity.Types.Model.Interaction ( + Interaction (..), + InteractionToken (..), + InteractionData (..), + ResolvedInteractionData (..), + InteractionType (..), + Application, + ApplicationCommand, +) where + +import Calamity.Types.Model.Channel (Attachment, Channel, Partial) +import Calamity.Types.Model.Channel.Component +import Calamity.Types.Model.Channel.Message (Message) +import Calamity.Types.Model.Guild (Guild, Role) +import Calamity.Types.Model.Guild.Member (Member) +import Calamity.Types.Model.User (User) +import Calamity.Types.Snowflake +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.HashMap.Strict qualified as H +import Data.Scientific (toBoundedInteger) +import Data.Text qualified as T +import Optics.TH +import TextShow qualified +import TextShow.TH + +-- | Empty type to flag application IDs +data Application + +-- | Empty type to flag application command IDs +data ApplicationCommand + +newtype InteractionToken = InteractionToken + { fromInteractionToken :: T.Text + } + deriving stock (Show) + deriving (Aeson.FromJSON, Aeson.ToJSON) via T.Text + +data Interaction = Interaction + { id :: Snowflake Interaction + , applicationID :: Snowflake Application + , type_ :: InteractionType + , data_ :: Maybe InteractionData + , guildID :: Maybe (Snowflake Guild) + , channelID :: Maybe (Snowflake Channel) + , member :: Maybe Member + , user :: Maybe User + , token :: InteractionToken + , version :: Int + , message :: Maybe Message + , locale :: Maybe T.Text + , guildLocale :: Maybe T.Text + } + deriving (Show) + deriving (HasID Interaction) via HasIDField "id" Interaction + deriving (HasID Application) via HasIDField "applicationID" Interaction + +instance Aeson.FromJSON Interaction where + parseJSON = Aeson.withObject "Interaction" $ \v -> + Interaction + <$> v .: "id" + <*> v .: "application_id" + <*> v .: "type" + <*> v .:? "data" + <*> v .:? "guild_id" + <*> v .:? "channel_id" + <*> v .:? "member" + <*> v .:? "user" + <*> v .: "token" + <*> v .: "version" + <*> v .:? "message" + <*> v .:? "locale" + <*> v .:? "guild_locale" + +data InteractionData = InteractionData + { id :: Maybe (Snowflake ApplicationCommand) + , name :: Maybe T.Text + , resolved :: Maybe ResolvedInteractionData + , -- , options :: [ApplicationCommandInteractionDataOptions] + -- No commands yet + customID :: Maybe CustomID + , componentType :: Maybe ComponentType + , values :: Maybe [T.Text] + , targetID :: Maybe (Snowflake ()) + , components :: Maybe [Aeson.Value] + } + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow InteractionData + +instance Aeson.FromJSON InteractionData where + parseJSON = Aeson.withObject "InteractionData" $ \v -> + InteractionData + <$> v .:? "id" + <*> v .:? "name" + <*> v .:? "resolved" + <*> v .:? "custom_id" + <*> v .:? "component_type" + <*> v .:? "values" + <*> v .:? "target_id" + <*> v .:? "components" + +data ResolvedInteractionData = ResolvedInteractionData + { users :: H.HashMap (Snowflake User) User + , members :: H.HashMap (Snowflake Member) Member + , roles :: H.HashMap (Snowflake Role) Role + , channels :: H.HashMap (Snowflake Channel) (Partial Channel) + , messages :: H.HashMap (Snowflake Message) (Partial Message) + , attachments :: H.HashMap (Snowflake Attachment) Attachment + } + deriving (Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow ResolvedInteractionData + +instance Aeson.FromJSON ResolvedInteractionData where + parseJSON = Aeson.withObject "ResolvedInteractionData" $ \v -> + ResolvedInteractionData + <$> v .:? "users" .!= H.empty + <*> v .:? "members" .!= H.empty + <*> v .:? "roles" .!= H.empty + <*> v .:? "channels" .!= H.empty + <*> v .:? "messages" .!= H.empty + <*> v .:? "attachments" .!= H.empty + +data InteractionType + = PingType + | ApplicationCommandType + | MessageComponentType + | ApplicationCommandAutoCompleteType + | ModalSubmitType + deriving (Eq, Show) + +instance Aeson.FromJSON InteractionType where + parseJSON = Aeson.withScientific "InteractionType" $ \n -> case toBoundedInteger @Int n of + Just 1 -> pure PingType + Just 2 -> pure ApplicationCommandType + Just 3 -> pure MessageComponentType + Just 4 -> pure ApplicationCommandAutoCompleteType + Just 5 -> pure ModalSubmitType + _ -> fail $ "Invalid InteractionType: " <> show n + +$(deriveTextShow ''InteractionToken) +$(deriveTextShow ''InteractionType) +$(deriveTextShow ''Interaction) +$(makeFieldLabelsNoPrefix ''InteractionToken) +$(makeFieldLabelsNoPrefix ''Interaction) +$(makeFieldLabelsNoPrefix ''InteractionData) +$(makeFieldLabelsNoPrefix ''ResolvedInteractionData) +$(makeFieldLabelsNoPrefix ''InteractionType) diff --git a/Calamity/Types/Model/Presence.hs b/Calamity/Types/Model/Presence.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Presence.hs @@ -0,0 +1,8 @@ +-- | User presences +module Calamity.Types.Model.Presence ( + module Calamity.Types.Model.Presence.Presence, + module Calamity.Types.Model.Presence.Activity, +) where + +import Calamity.Types.Model.Presence.Activity +import Calamity.Types.Model.Presence.Presence diff --git a/Calamity/Types/Model/Presence/Activity.hs b/Calamity/Types/Model/Presence/Activity.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Presence/Activity.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | User activities +module Calamity.Types.Model.Presence.Activity ( + Activity (..), + activity, + ActivityType (..), + ActivityTimestamps (..), + ActivityParty (..), + ActivityAssets (..), + ActivitySecrets (..), +) where + +import Calamity.Internal.UnixTimestamp +import Calamity.Internal.Utils +import Calamity.Types.Snowflake +import Data.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 TextShow qualified +import TextShow.TH + +data ActivityType + = Game + | Streaming + | Listening + | Custom + | Other Int + deriving (Eq, Show) + +instance Aeson.ToJSON ActivityType where + toJSON Game = Aeson.Number 0 + toJSON Streaming = Aeson.Number 1 + toJSON Listening = Aeson.Number 2 + toJSON Custom = Aeson.Number 4 + toJSON (Other n) = Aeson.Number $ fromIntegral n + +instance Aeson.FromJSON ActivityType where + parseJSON = Aeson.withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of + Just v -> case v of + 0 -> pure Game + 1 -> pure Streaming + 2 -> pure Listening + 4 -> pure Custom + n -> pure $ Other n + Nothing -> fail $ "Invalid ActivityType: " <> show n + +data Activity = Activity + { name :: Text + , type_ :: ActivityType + , url :: Maybe Text + , timestamps :: Maybe ActivityTimestamps + , applicationID :: Maybe (Snowflake ()) + , details :: Maybe Text + , state :: Maybe Text + , party :: Maybe ActivityParty + , assets :: Maybe ActivityAssets + , secrets :: Maybe ActivitySecrets + , instance_ :: Maybe Bool + , flags :: Maybe Word64 + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON Activity + +instance CalamityToJSON' Activity where + toPairs Activity {..} = + [ "name" .= name + , "type" .= type_ + , "url" .?= url + , "timestamps" .?= timestamps + , "application_id" .?= applicationID + , "details" .?= details + , "state" .?= state + , "party" .?= party + , "assets" .?= assets + , "secrets" .?= secrets + , "instance" .?= instance_ + , "flags" .?= flags + ] + +instance Aeson.FromJSON Activity where + parseJSON = Aeson.withObject "Activity" $ \v -> + Activity + <$> v .: "name" + <*> v .: "type" + <*> v .:? "url" + <*> v .:? "timestamps" + <*> v .:? "application_id" + <*> v .:? "details" + <*> v .:? "state" + <*> v .:? "party" + <*> v .:? "assets" + <*> v .:? "secrets" + <*> v .:? "instance" + <*> v .:? "flags" + +-- | Make an 'Activity' with all optional fields set to Nothing +activity :: Text -> ActivityType -> Activity +activity !name !type_ = + Activity + { name = name + , type_ = type_ + , url = Nothing + , timestamps = Nothing + , applicationID = Nothing + , details = Nothing + , state = Nothing + , party = Nothing + , assets = Nothing + , secrets = Nothing + , instance_ = Nothing + , flags = Nothing + } + +data ActivityTimestamps = ActivityTimestamps + { start :: Maybe UTCTime + , end :: Maybe UTCTime + } + deriving (Eq, Show) + deriving (TextShow.TextShow) via TextShow.FromStringShow ActivityTimestamps + deriving (Aeson.ToJSON) via CalamityToJSON ActivityTimestamps + +instance CalamityToJSON' ActivityTimestamps where + toPairs ActivityTimestamps {..} = + [ "start" .?= fmap UnixTimestamp start + , "end" .?= fmap UnixTimestamp end + ] + +instance Aeson.FromJSON ActivityTimestamps where + parseJSON = Aeson.withObject "ActivityTimestamps" $ \v -> + ActivityTimestamps + <$> (fmap unUnixTimestamp <$> v .:? "start") + <*> (fmap unUnixTimestamp <$> v .:? "end") + +data ActivityParty = ActivityParty + { id :: Maybe Text + , size :: Maybe (Int, Int) + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ActivityParty + +instance CalamityToJSON' ActivityParty where + toPairs ActivityParty {..} = + [ "id" .?= id + , "size" .?= size + ] + +instance Aeson.FromJSON ActivityParty where + parseJSON = Aeson.withObject "ActivityParty" $ \v -> + ActivityParty + <$> v .:? "id" + <*> v .:? "size" + +data ActivityAssets = ActivityAssets + { largeImage :: Maybe Text + , largeText :: Maybe Text + , smallImage :: Maybe Text + , smallText :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ActivityAssets + +instance CalamityToJSON' ActivityAssets where + toPairs ActivityAssets {..} = + [ "large_image" .?= largeImage + , "large_text" .?= largeText + , "small_image" .?= smallImage + , "small_text" .?= smallText + ] + +instance Aeson.FromJSON ActivityAssets where + parseJSON = Aeson.withObject "ActivityAssets" $ \v -> + ActivityAssets + <$> v .:? "large_image" + <*> v .:? "large_text" + <*> v .:? "small_image" + <*> v .:? "small_text" + +data ActivitySecrets = ActivitySecrets + { join :: Maybe Text + , spectate :: Maybe Text + , match :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ActivitySecrets + +instance CalamityToJSON' ActivitySecrets where + toPairs ActivitySecrets {..} = + [ "join" .?= join + , "spectate" .?= spectate + , "match" .?= match + ] + +instance Aeson.FromJSON ActivitySecrets where + parseJSON = Aeson.withObject "ActivitySecrets" $ \v -> + ActivitySecrets + <$> v .:? "join" + <*> v .:? "spectate" + <*> v .:? "match" + +$(deriveTextShow ''ActivityType) +$(deriveTextShow ''ActivityParty) +$(deriveTextShow ''ActivityAssets) +$(deriveTextShow ''ActivitySecrets) +$(deriveTextShow ''Activity) +$(makeFieldLabelsNoPrefix ''Activity) +$(makeFieldLabelsNoPrefix ''ActivityTimestamps) +$(makeFieldLabelsNoPrefix ''ActivityParty) +$(makeFieldLabelsNoPrefix ''ActivityAssets) +$(makeFieldLabelsNoPrefix ''ActivitySecrets) diff --git a/Calamity/Types/Model/Presence/Presence.hs b/Calamity/Types/Model/Presence/Presence.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Presence/Presence.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | User presences +module Calamity.Types.Model.Presence.Presence ( + Presence (..), + ClientStatus (..), +) where + +import Calamity.Internal.Utils +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.Presence.Activity +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data Presence = Presence + { user :: Snowflake User + , guildID :: Snowflake Guild + , status :: StatusType + , activities :: [Activity] + , clientStatus :: ClientStatus + } + deriving (Eq, Show) + deriving (HasID User) via HasIDField "user" Presence + deriving (HasID Guild) via HasIDField "guildID" Presence + +instance Aeson.FromJSON Presence where + parseJSON = Aeson.withObject "Presence" $ \v -> do + u :: Aeson.Object <- v .: "user" + + Presence + <$> u .: "id" + <*> v .: "guild_id" + <*> v .: "status" + <*> v .: "activities" + <*> v .: "client_status" + +data ClientStatus = ClientStatus + { desktop :: Maybe Text + , mobile :: Maybe Text + , web :: Maybe Text + } + deriving (Eq, Show) + deriving (Aeson.ToJSON) via CalamityToJSON ClientStatus + +instance CalamityToJSON' ClientStatus where + toPairs ClientStatus {..} = + [ "desktop" .?= desktop + , "mobile" .?= mobile + , "web" .?= web + ] + +instance Aeson.FromJSON ClientStatus where + parseJSON = Aeson.withObject "ClientStatus" $ \v -> + ClientStatus + <$> v .:? "desktop" + <*> v .:? "mobile" + <*> v .:? "web" + +$(deriveTextShow ''ClientStatus) +$(deriveTextShow ''Presence) +$(makeFieldLabelsNoPrefix ''Presence) +$(makeFieldLabelsNoPrefix ''ClientStatus) diff --git a/Calamity/Types/Model/User.hs b/Calamity/Types/Model/User.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/User.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A User +module Calamity.Types.Model.User ( + User (..), + UserBanner (..), + Partial (PartialUser), + StatusType (..), +) where + +import Calamity.Internal.IntColour +import Calamity.Types.CDNAsset (CDNAsset (..)) +import Calamity.Types.Model.Avatar +import {-# SOURCE #-} Calamity.Types.Model.Guild.Member +import Calamity.Types.Partial +import Calamity.Types.Snowflake +import Calamity.Utils.CDNUrl (assetHashFile, cdnURL) +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Colour (Colour) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Read (decimal) +import Data.Word +import Network.HTTP.Req ((/:), (/~)) +import Optics.TH +import TextShow qualified +import TextShow.TH + +data UserBanner = UserBanner + { userID :: Snowflake User + , hash :: T.Text + } + deriving (Show, Eq) + +instance CDNAsset UserBanner where + assetURL UserBanner {hash, userID} = + cdnURL /: "banners" /~ userID /: assetHashFile hash + +data User = User + { id :: Snowflake User + , username :: Text + , discriminator :: Text + , bot :: Maybe Bool + , avatar :: Avatar + , mfaEnabled :: Maybe Bool + , banner :: Maybe UserBanner + , accentColour :: Maybe (Colour Double) + , locale :: Maybe Text + , verified :: Maybe Bool + , email :: Maybe Text + , flags :: Maybe Word64 + , premiumType :: Maybe Word64 + } + deriving (Show, Eq) + deriving (TextShow.TextShow) via TextShow.FromStringShow User + deriving (HasID User) via HasIDField "id" User + deriving (HasID Member) via HasIDFieldCoerce' "id" User + +instance Aeson.FromJSON User where + parseJSON = Aeson.withObject "User" $ \v -> do + uid <- v .: "id" + avatarHash <- v .:? "avatar" + discrim <- v .: "discriminator" + discrim' <- case decimal discrim of + Right (n, _) -> pure n + Left e -> fail e + let avatar = Avatar avatarHash uid discrim' + banner <- (UserBanner uid <$>) <$> v .:? "banner" + User + <$> pure uid + <*> v .: "username" + <*> v .: "discriminator" + <*> v .:? "bot" + <*> pure avatar + <*> v .:? "mfa_enabled" + <*> pure banner + <*> (fmap fromIntColour <$> v .:? "accent_color") + <*> v .:? "locale" + <*> v .:? "verified" + <*> v .:? "email" + <*> v .:? "flags" + <*> v .:? "premium_type" + +newtype instance Partial User = PartialUser + { id :: Snowflake User + } + deriving stock (Show, Eq) + deriving (HasID User) via HasIDField "id" (Partial User) + +instance Aeson.FromJSON (Partial User) where + parseJSON = Aeson.withObject "Partial User" $ \v -> + PartialUser <$> v .: "id" + +data StatusType + = Idle + | DND + | Online + | Offline + | Invisible + deriving (Eq, Show, Enum) + +instance Aeson.FromJSON StatusType where + parseJSON = Aeson.withText "StatusType" $ \case + "idle" -> pure Idle + "dnd" -> pure DND + "online" -> pure Online + "offline" -> pure Offline + "invisible" -> pure Invisible + _ -> fail "Unknown status type" + +instance Aeson.ToJSON StatusType where + toJSON = + Aeson.toJSON @Text . \case + Idle -> "idle" + DND -> "dnd" + Online -> "online" + Offline -> "offline" + Invisible -> "invisible" + +$(deriveTextShow 'PartialUser) +$(deriveTextShow ''StatusType) +$(makeFieldLabelsNoPrefix ''User) +$(makeFieldLabelsNoPrefix 'PartialUser) +$(makeFieldLabelsNoPrefix ''StatusType) diff --git a/Calamity/Types/Model/User.hs-boot b/Calamity/Types/Model/User.hs-boot new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/User.hs-boot @@ -0,0 +1,8 @@ +-- | Users +module Calamity.Types.Model.User + ( User ) where + +data User + +instance Show User +instance Eq User diff --git a/Calamity/Types/Model/Voice.hs b/Calamity/Types/Model/Voice.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Voice.hs @@ -0,0 +1,8 @@ +-- | Voice data types +module Calamity.Types.Model.Voice ( + module Calamity.Types.Model.Voice.VoiceState, + module Calamity.Types.Model.Voice.VoiceRegion, +) where + +import Calamity.Types.Model.Voice.VoiceRegion +import Calamity.Types.Model.Voice.VoiceState diff --git a/Calamity/Types/Model/Voice/VoiceRegion.hs b/Calamity/Types/Model/Voice/VoiceRegion.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Voice/VoiceRegion.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Voice regions +module Calamity.Types.Model.Voice.VoiceRegion (VoiceRegion (..)) where + +import Calamity.Internal.Utils +import Calamity.Types.Snowflake +import Data.Aeson ((.:)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data VoiceRegion = VoiceRegion + { id :: Snowflake VoiceRegion + , name :: Text + , vip :: Bool + , optimal :: Bool + , deprecated :: Bool + , custom :: Bool + } + deriving (Show, Eq) + deriving (Aeson.ToJSON) via CalamityToJSON VoiceRegion + +instance CalamityToJSON' VoiceRegion where + toPairs VoiceRegion {..} = + [ "id" .= id + , "name" .= name + , "vip" .= vip + , "optimal" .= optimal + , "deprecated" .= deprecated + , "custom" .= custom + ] + +instance Aeson.FromJSON VoiceRegion where + parseJSON = Aeson.withObject "VoiceRegion" $ \v -> + VoiceRegion + <$> v .: "id" + <*> v .: "name" + <*> v .: "vip" + <*> v .: "optimal" + <*> v .: "deprecated" + <*> v .: "custom" + +$(deriveTextShow ''VoiceRegion) +$(makeFieldLabelsNoPrefix ''VoiceRegion) diff --git a/Calamity/Types/Model/Voice/VoiceState.hs b/Calamity/Types/Model/Voice/VoiceState.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Model/Voice/VoiceState.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Calamity.Types.Model.Voice.VoiceState (VoiceState (..)) where + +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel.Guild.Voice +import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Text (Text) +import Optics.TH +import TextShow.TH + +data VoiceState = VoiceState + { guildID :: Maybe (Snowflake Guild) + , channelID :: Maybe (Snowflake VoiceChannel) + , userID :: Snowflake User + , sessionID :: Text + , deaf :: Bool + , mute :: Bool + , selfDeaf :: Bool + , selfMute :: Bool + , suppress :: Bool + } + deriving (Show, Eq) + deriving (Aeson.ToJSON) via CalamityToJSON VoiceState + +instance CalamityToJSON' VoiceState where + toPairs VoiceState {..} = + [ "guild_id" .= guildID + , "channel_id" .= channelID + , "user_id" .= userID + , "session_id" .= sessionID + , "deaf" .= deaf + , "mute" .= mute + , "self_deaf" .= selfDeaf + , "self_mute" .= selfMute + , "suppress" .= suppress + ] + +instance Aeson.FromJSON VoiceState where + parseJSON = Aeson.withObject "VoiceState" $ \v -> + VoiceState + <$> v .:? "guild_id" + <*> v .:? "channel_id" + <*> v .: "user_id" + <*> v .: "session_id" + <*> v .: "deaf" + <*> v .: "mute" + <*> v .: "self_deaf" + <*> v .: "self_mute" + <*> v .: "suppress" + +$(deriveTextShow ''VoiceState) +$(makeFieldLabelsNoPrefix ''VoiceState) diff --git a/Calamity/Types/Partial.hs b/Calamity/Types/Partial.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Partial.hs @@ -0,0 +1,4 @@ +-- | Partial data family +module Calamity.Types.Partial (Partial) where + +data family Partial t diff --git a/Calamity/Types/Snowflake.hs b/Calamity/Types/Snowflake.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Snowflake.hs @@ -0,0 +1,82 @@ +-- | The snowflake type +module Calamity.Types.Snowflake ( + Snowflake (..), + HasID (..), + type HasID', + HasIDField (..), + HasIDFieldCoerce (..), + type HasIDFieldCoerce', + coerceSnowflake, +) where + +import Data.Aeson +import Data.Bits +import Data.Data +import Data.Hashable +import Data.Kind +import Data.Text.Read +import Data.Vector.Unboxing qualified as U +import Data.Word +import GHC.Records (HasField (getField)) +import TextShow +import Web.HttpApiData (ToHttpApiData) + +-- Thanks sbrg +-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78 +newtype Snowflake (t :: Type) = Snowflake + { fromSnowflake :: Word64 + } + deriving stock (Eq, Ord, Data) + deriving newtype (Show, TextShow, FromJSONKey) + deriving newtype (ToJSONKey, U.Unboxable) + deriving newtype (ToHttpApiData) + +-- I'm pretty sure that Word64's hash just being 'fromIntegral' is a bad idea when +-- attempting to use it in a hashmap, so swizzle the bits a bit to give a good +-- distribution of bits +instance Hashable (Snowflake t) where + hashWithSalt salt (Snowflake a) = + let initial = fromIntegral @_ @Word64 $ hashWithSalt salt a + round1 = (initial `shiftR` 30 `xor` initial) * 0xbf58476d1ce4e5b9 + round2 = (round1 `shiftR` 27 `xor` round1) * 0xbf58476d1ce4e5b9 + round3 = (round2 `shiftR` 31 `xor` round2) + in fromIntegral @_ @Int round3 + +instance ToJSON (Snowflake t) where + toJSON (Snowflake s) = String . showt $ s + +instance FromJSON (Snowflake t) where + parseJSON = withText "Snowflake" $ \t -> do + n <- case decimal t of + Right (n, _) -> pure n + Left e -> fail e + pure $ Snowflake n + +coerceSnowflake :: Snowflake a -> Snowflake b +coerceSnowflake (Snowflake t) = Snowflake t + +-- | A typeclass for types that contain snowflakes of type `b` +class HasID b a where + -- | Retrieve the ID from the type + getID :: a -> Snowflake b + +type HasID' a = HasID a a + +-- | A newtype wrapper for deriving HasID generically +newtype HasIDField field a = HasIDField a + +instance (HasID b c, HasField field a c) => HasID b (HasIDField field a) where + getID (HasIDField a) = getID @b @c $ getField @field a + +{- | A data `a` which contains an ID of type `Snowflake c` + which should be swapped with `Snowflake b` upon fetching +-} +newtype HasIDFieldCoerce field a c = HasIDFieldCoerce a + +type HasIDFieldCoerce' field a = HasIDFieldCoerce field a a + +instance (HasID c d, HasField field a d) => HasID b (HasIDFieldCoerce field a c) where + getID (HasIDFieldCoerce a) = coerceSnowflake . getID @c $ getField @field a + +instance HasID a (Snowflake a) where + getID = id diff --git a/Calamity/Types/Tellable.hs b/Calamity/Types/Tellable.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Tellable.hs @@ -0,0 +1,221 @@ +-- | Things that are messageable +module Calamity.Types.Tellable ( + ToMessage (..), + Tellable (..), + TMention (..), + tell, + reply, + runToMessage, +) where + +import Calamity.Client.Types +import Calamity.HTTP.Channel ( + AllowedMentions, + ChannelRequest (CreateMessage), + CreateMessageAttachment, + CreateMessageOptions, + ) +import Calamity.HTTP.Internal.Request (invoke) +import Calamity.HTTP.Internal.Types (RestError) +import Calamity.HTTP.User (UserRequest (CreateDM)) +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Member (Member) +import Calamity.Types.Model.Guild.Role (Role) +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Default.Class +import Data.Monoid +import Data.Text qualified as T +import Data.Text.Lazy qualified as L +import Optics +import Polysemy qualified as P +import Polysemy.Error qualified as P + +-- | A wrapper type for allowing mentions +newtype TMention a = TMention (Snowflake a) + deriving stock (Show) + +{- | Things that can be used to send a message + + Can be used to compose text, embeds, and files. /e.g./ + + @ + 'intoMsg' @'L.Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description") + @ +-} +class ToMessage a where + -- | Turn @a@ into a 'CreateMessageOptions' builder + intoMsg :: a -> Endo CreateMessageOptions + +-- | Message content, '(<>)' concatenates the content +instance ToMessage L.Text where + intoMsg t = Endo (#content %~ (<> Just (L.toStrict t))) + +-- | Message content, '(<>)' concatenates the content +instance ToMessage T.Text where + intoMsg t = Endo (#content %~ (<> Just t)) + +-- | Message content, '(<>)' concatenates the content +instance ToMessage String where + intoMsg t = Endo (#content %~ (<> Just (T.pack t))) + +-- | Message embed, '(<>)' appends a new embed +instance ToMessage Embed where + intoMsg e = Endo (#embeds %~ (<> Just [e])) + +-- | Message attachments, '(<>)' appends a new file +instance ToMessage CreateMessageAttachment where + intoMsg a = Endo (#attachments %~ (<> Just [a])) + +-- | Allowed mentions, '(<>)' combines allowed mentions +instance ToMessage AllowedMentions where + intoMsg m = Endo (#allowedMentions %~ (<> Just m)) + +-- | Add a 'User' id to the list of allowed user mentions +instance ToMessage (TMention User) where + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users %~ (<> [s])) + +-- | Add a 'Member' id to the list of allowed user mentions +instance ToMessage (TMention Member) where + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users %~ (<> [coerceSnowflake s])) + +-- | Add a 'Role' id to the list of allowed role mentions +instance ToMessage (TMention Role) where + intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles %~ (<> [s])) + +fixupActionRow :: Component -> Component +fixupActionRow r@(ActionRow' _) = r +fixupActionRow x = ActionRow' [x] + +{- | Add many components to a message. + + Each component will be wrapped in a singleton ActionRow if not already +-} +instance ToMessage [Component] where + intoMsg c = Endo (#components %~ (<> Just (map fixupActionRow c))) + +-- | Add an row of 'Button's to the message +instance ToMessage [Button] where + intoMsg c = Endo (#components %~ (<> Just [ActionRow' . map Button' $ c])) + +-- | Add an row of 'LinkButton's to the message +instance ToMessage [LinkButton] where + intoMsg c = Endo (#components %~ (<> Just [ActionRow' . map LinkButton' $ c])) + +-- | Add an row of 'Select's to the message +instance ToMessage [Select] where + intoMsg c = Endo (#components %~ (<> Just [ActionRow' . map Select' $ c])) + +{- | Add a singleton row containing a 'Component' to the message + + If the component is not already an actionrow, it is wrapped in a singleton row +-} +instance ToMessage Component where + intoMsg c = Endo (#components %~ (<> Just [fixupActionRow c])) + +-- | Add a singleton row containing a 'Button' to the message, +instance ToMessage Button where + intoMsg c = Endo (#components %~ (<> Just [ActionRow' [Button' c]])) + +-- | Add a singleton row containing a 'LinkButton' to the message, +instance ToMessage LinkButton where + intoMsg c = Endo (#components %~ (<> Just [ActionRow' [LinkButton' c]])) + +-- | Add a singleton row containing a 'Select' to the message, +instance ToMessage Select where + intoMsg c = Endo (#components %~ (<> Just [ActionRow' [Select' c]])) + +-- | Set a 'MessageReference' as the message to reply to +instance ToMessage MessageReference where + intoMsg ref = Endo (#messageReference ?~ ref) + +instance ToMessage (Endo CreateMessageOptions) where + intoMsg = Prelude.id + +instance ToMessage (CreateMessageOptions -> CreateMessageOptions) where + intoMsg = Endo + +instance ToMessage CreateMessageOptions where + intoMsg = Endo . const + +class Tellable a where + getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel) + +runToMessage :: (ToMessage a) => a -> CreateMessageOptions +runToMessage = flip appEndo def . intoMsg + +{- | Send a message to something that is messageable + + To send a string literal you'll probably want to use @TypeApplication@ to + specify the type of @msg@ + + ==== Examples + + Sending a string: + + @ + 'void' $ 'tell' @'Text' m ("Somebody told me to tell you about: " '<>' s) + @ +-} +tell :: forall msg r t. (BotC r, ToMessage msg, Tellable t) => t -> msg -> P.Sem r (Either RestError Message) +tell target (runToMessage -> msg) = P.runError $ do + cid <- getChannel target + r <- invoke $ CreateMessage cid msg + P.fromEither r + +{- | Create a reply to an existing message in the same channel + + To send a string literal you'll probably want to use @TypeApplication@ to + specify the type of @msg@ + + ==== Examples + + Sending a string: + + @ + 'void' $ 'reply' @'Text' msgToReplyTo ("Somebody told me to tell you about: " '<>' s) + @ +-} +reply :: forall msg r t. (BotC r, ToMessage msg, HasID Channel t, HasID Message t) => t -> msg -> P.Sem r (Either RestError Message) +reply target msg = P.runError $ do + let msg' = runToMessage (intoMsg msg <> intoMsg (MessageReference (Just $ getID @Message target) (Just $ getID @Channel target) Nothing False)) + r <- invoke $ CreateMessage (getID @Channel target) msg' + P.fromEither r + +instance Tellable DMChannel where + getChannel = pure . getID + +instance Tellable (Snowflake Channel) where + getChannel = pure + +instance Tellable Channel where + getChannel = pure . getID + +instance Tellable (Snowflake DMChannel) where + getChannel = pure . coerceSnowflake + +instance Tellable TextChannel where + getChannel = pure . getID + +instance Tellable (Snowflake TextChannel) where + getChannel = pure . coerceSnowflake + +instance Tellable Message where + getChannel = pure . getID + +messageUser :: (BotC r, P.Member (P.Error RestError) r, HasID User a) => a -> P.Sem r (Snowflake Channel) +messageUser (getID @User -> uid) = do + c <- invoke $ CreateDM uid + getID <$> P.fromEither c + +instance Tellable (Snowflake Member) where + getChannel = messageUser . coerceSnowflake @_ @User + +instance Tellable Member where + getChannel = messageUser + +instance Tellable User where + getChannel = messageUser + +instance Tellable (Snowflake User) where + getChannel = messageUser diff --git a/Calamity/Types/Token.hs b/Calamity/Types/Token.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Token.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Discord tokens +module Calamity.Types.Token ( + Token (..), + formatToken, + rawToken, +) where + +import Data.Text (Text) +import Optics.TH +import TextShow.TH (deriveTextShow) + +data Token + = BotToken Text + | UserToken Text + deriving (Show) + +formatToken :: Token -> Text +formatToken (BotToken t) = "Bot " <> t +formatToken (UserToken t) = t + +rawToken :: Token -> Text +rawToken (BotToken t) = t +rawToken (UserToken t) = t + +$(deriveTextShow ''Token) +$(makeFieldLabelsNoPrefix ''Token) diff --git a/Calamity/Types/TokenEff.hs b/Calamity/Types/TokenEff.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/TokenEff.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Calamity.Types.TokenEff ( + TokenEff (..), + getBotToken, +) where + +import Calamity.Types.Token +import Polysemy + +data TokenEff m a where + GetBotToken :: TokenEff m Token + +makeSem ''TokenEff diff --git a/Calamity/Types/Upgradeable.hs b/Calamity/Types/Upgradeable.hs new file mode 100644 --- /dev/null +++ b/Calamity/Types/Upgradeable.hs @@ -0,0 +1,141 @@ +-- | Things that can be upgraded from snowflakes to their full data +module Calamity.Types.Upgradeable (Upgradeable (..)) where + +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. +-} +class Upgradeable a ids | a -> ids, ids -> a where + -- | Upgrade a snowflake to its complete data. + -- + -- If it existed in the cache then it is returned from there, otherwise we + -- fetch from HTTP and update the cache on success. + upgrade :: (BotC r) => ids -> P.Sem r (Maybe a) + +maybeToAlt :: (Alternative f) => Maybe a -> f a +maybeToAlt (Just x) = pure x +maybeToAlt Nothing = empty + +instance Upgradeable User (Snowflake User) where + upgrade uid = P.runNonDetMaybe ((getUser uid >>= maybeToAlt) <|> gethttp) + where + gethttp = P.failToNonDet $ do + Right u <- invoke $ H.GetUser uid + setUser u + pure u + +instance Upgradeable Member (Snowflake Guild, Snowflake Member) where + upgrade (gid, mid) = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = P.failToNonDet $ do + Just g <- getGuild gid + Just m <- pure (g ^. #members % at mid) + pure m + gethttp = P.failToNonDet $ do + Right m <- invoke $ H.GetGuildMember gid (coerceSnowflake @_ @User mid) + -- getcache could have failed becuase the member wasn't cached + updateGuild gid (#members % at mid ?~ m) + pure m + +instance Upgradeable Guild (Snowflake Guild) where + upgrade gid = P.runNonDetMaybe ((getGuild gid >>= maybeToAlt) <|> gethttp) + where + gethttp = P.failToNonDet $ do + Right g <- invoke $ H.GetGuild gid + pure g + +insertChannel :: (BotC r) => Channel -> P.Sem r () +insertChannel (DMChannel' dm) = setDM dm +insertChannel (GuildChannel' ch) = + updateGuild (getID ch) (#channels % at (getID @GuildChannel ch) ?~ ch) +insertChannel _ = pure () + +instance Upgradeable Channel (Snowflake Channel) where + upgrade cid = P.runNonDetMaybe (getcacheDM <|> getcacheGuild <|> gethttp) + where + getcacheDM = DMChannel' <<$>> getDM (coerceSnowflake cid) >>= maybeToAlt + getcacheGuild = GuildChannel' <<$>> getGuildChannel (coerceSnowflake cid) >>= maybeToAlt + gethttp = P.failToNonDet $ do + Right c <- invoke $ H.GetChannel cid + insertChannel c + pure c + +instance Upgradeable GuildChannel (Snowflake GuildChannel) where + upgrade cid = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = getGuildChannel (coerceSnowflake cid) >>= maybeToAlt + gethttp = P.failToNonDet $ do + Right c <- invoke $ H.GetChannel (coerceSnowflake @_ @Channel cid) + insertChannel c + GuildChannel' c' <- pure c + pure c' + +instance Upgradeable VoiceChannel (Snowflake VoiceChannel) where + 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 + +instance Upgradeable GroupChannel (Snowflake GroupChannel) where + 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 + +instance Upgradeable Category (Snowflake Category) where + 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) + where + getcache = P.failToNonDet $ do + Just g <- getGuild gid + Just m <- pure (g ^. #emojis % at eid) + pure m + gethttp = P.failToNonDet $ do + Right e <- invoke $ H.GetGuildEmoji gid eid + updateGuild gid (#emojis % at eid ?~ e) + pure e + +instance Upgradeable Role (Snowflake Guild, Snowflake Role) where + upgrade (gid, rid) = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = P.failToNonDet $ do + Just g <- getGuild gid + Just r <- pure (g ^. #roles % at rid) + pure r + gethttp = P.failToNonDet $ do + Right rs <- invoke $ H.GetGuildRoles gid + let sm = SM.fromList rs + updateGuild gid (#roles %~ (<> sm)) + Just r <- pure (sm ^. at rid) + pure r diff --git a/Calamity/Utils.hs b/Calamity/Utils.hs new file mode 100644 --- /dev/null +++ b/Calamity/Utils.hs @@ -0,0 +1,10 @@ +-- | Useful things +module Calamity.Utils ( + module Calamity.Utils.Permissions, + module Calamity.Utils.Message, + module Calamity.Utils.Colour, +) where + +import Calamity.Utils.Colour +import Calamity.Utils.Message +import Calamity.Utils.Permissions diff --git a/Calamity/Utils/CDNUrl.hs b/Calamity/Utils/CDNUrl.hs new file mode 100644 --- /dev/null +++ b/Calamity/Utils/CDNUrl.hs @@ -0,0 +1,23 @@ +-- | CDN url stuff +module Calamity.Utils.CDNUrl ( + cdnURL, + assetHashFile, + isGIFAsset, +) where + +import Data.Text qualified as T +import Network.HTTP.Req qualified as Req + +-- | The CDN URL +cdnURL :: Req.Url 'Req.Https +cdnURL = Req.https "cdn.discordapp.com" + +-- | Test if an asset hash is animated +isGIFAsset :: T.Text -> Bool +isGIFAsset = T.isPrefixOf "a_" + +{- | Generate \'hash.ext\' for an asset hash. @ext@ will be \'gif\' for animated + assets, \'png\' otherwise. +-} +assetHashFile :: T.Text -> T.Text +assetHashFile h = if isGIFAsset h then h <> ".gif" else h <> ".png" diff --git a/Calamity/Utils/Colour.hs b/Calamity/Utils/Colour.hs new file mode 100644 --- /dev/null +++ b/Calamity/Utils/Colour.hs @@ -0,0 +1,20 @@ +-- | Discord colour utilities +module Calamity.Utils.Colour ( + colourToWord64, + colourFromWord64, + + -- * Useful colours + blurple, + greyple, +) where + +import Calamity.Internal.IntColour + +import Data.Colour +import Data.Colour.SRGB (sRGB24) + +blurple :: (Ord a, Floating a) => Colour a +blurple = sRGB24 0x72 0x89 0xda + +greyple :: (Ord a, Floating a) => Colour a +greyple = sRGB24 0x99 0xaa 0xb5 diff --git a/Calamity/Utils/Message.hs b/Calamity/Utils/Message.hs new file mode 100644 --- /dev/null +++ b/Calamity/Utils/Message.hs @@ -0,0 +1,236 @@ +-- | Things for formatting things +module Calamity.Utils.Message ( + codeblock, + codeblock', + codeline, + escapeCodeblocks, + escapeCodelines, + escapeBold, + escapeStrike, + escapeUnderline, + escapeSpoilers, + escapeFormatting, + bold, + strike, + underline, + quote, + quoteAll, + spoiler, + zws, + fmtEmoji, + displayUser, + Mentionable (..), + asReference, +) where + +import Calamity.Types.Model.Channel ( + Category, + Channel, + DMChannel, + GuildChannel, + Message, + MessageReference (MessageReference), + TextChannel, + VoiceChannel, + ) +import Calamity.Types.Model.Guild (Emoji (..), Member, Role) +import Calamity.Types.Model.User (User) +import Calamity.Types.Snowflake +import Data.Foldable (Foldable (foldl')) +import Data.Maybe (fromMaybe) +import Data.String (IsString, fromString) +import Data.Text qualified as T +import GHC.Records (HasField (getField)) +import Optics +import TextShow (TextShow (showt)) + +zws :: (IsString s) => s +zws = fromString "\x200b" + +-- | Replaces all occurences of @\`\`\`@ with @\`\\`\\`@ +escapeCodeblocks :: T.Text -> T.Text +escapeCodeblocks = T.replace "```" (T.intercalate zws $ replicate 3 "`") + +-- | Replaces all occurences of @\`\`@ with @\`\\`@ +escapeCodelines :: T.Text -> T.Text +escapeCodelines = T.replace "``" (T.intercalate zws $ replicate 2 "`") + +-- | Replaces all occurences of @\*\*@ with @\*\\*@ +escapeBold :: T.Text -> T.Text +escapeBold = T.replace "**" (T.intercalate zws $ replicate 2 "*") + +-- | Replaces all occurences of @\~\~@ with @\~\\~@ +escapeStrike :: T.Text -> T.Text +escapeStrike = T.replace "~~" (T.intercalate zws $ replicate 2 "~") + +-- | Replaces all occurences of @\_\_@ with @\_\\_@ +escapeUnderline :: T.Text -> T.Text +escapeUnderline = T.replace "__" (T.intercalate zws $ replicate 2 "_") + +-- | Replaces all occurences of @\|\|@ with @\|\\|@ +escapeSpoilers :: T.Text -> T.Text +escapeSpoilers = T.replace "||" (T.intercalate zws $ replicate 2 "|") + +-- | Escape all discord formatting +escapeFormatting :: T.Text -> T.Text +escapeFormatting = foldl' (.) Prelude.id [escapeCodelines, escapeCodeblocks, escapeBold, escapeStrike, escapeUnderline, escapeSpoilers, escapeFormatting] + +{- | Formats a lang and content into a codeblock + + >>> codeblock "hs" "x = y" + "```hs\nx = y\n```" + + Any codeblocks in the @content@ are escaped +-} +codeblock :: + -- | language + T.Text -> + -- | content + T.Text -> + T.Text +codeblock lang = codeblock' (Just lang) + +{- | Formats an optional lang and content into a codeblock + + Any codeblocks in the @content@ are escaped +-} +codeblock' :: + -- | language + Maybe T.Text -> + -- | content + T.Text -> + T.Text +codeblock' lang content = + "```" + <> fromMaybe "" lang + <> "\n" + <> escapeCodeblocks content + <> "\n```" + +{- | Formats some content into a code line + + This always uses @``@ code lines as they can be escaped + + Any code lines in the content are escaped +-} +codeline :: T.Text -> T.Text +codeline content = "``" <> escapeCodelines content <> "``" + +{- | Formats some text into its bolded form + + Any existing bolded text is escaped +-} +bold :: T.Text -> T.Text +bold content = "**" <> escapeBold content <> "**" + +{- | Formats some text into its striked form + + Any existing striked text is escaped +-} +strike :: T.Text -> T.Text +strike content = "~~" <> escapeStrike content <> "~~" + +{- | Formats some text into its underlined form + + Any existing underlined text is escaped +-} +underline :: T.Text -> T.Text +underline content = "__" <> escapeUnderline content <> "__" + +-- | Quotes a section of text +quote :: T.Text -> T.Text +quote = ("> " <>) + +-- | Quotes all remaining text +quoteAll :: T.Text -> T.Text +quoteAll = (">> " <>) + +{- | Formats some text into its spoilered form + + Any existing spoilers are escaped +-} +spoiler :: T.Text -> T.Text +spoiler content = "||" <> escapeSpoilers content <> "||" + +fmtEmoji :: Emoji -> T.Text +fmtEmoji Emoji {id, name, animated} = "<" <> ifanim <> ":" <> name <> ":" <> showt id <> ">" + where + ifanim = if animated then "a" else "" + +-- | Format a 'User' or 'Member' into the format of @username#discriminator@ +displayUser :: (HasField "username" a T.Text, HasField "discriminator" a T.Text) => a -> T.Text +displayUser u = getField @"username" u <> "#" <> getField @"discriminator" u + +mentionSnowflake :: T.Text -> Snowflake a -> T.Text +mentionSnowflake tag s = "<" <> tag <> showt s <> ">" + +-- | Things that can be mentioned +class Mentionable a where + mention :: a -> T.Text + +instance Mentionable (Snowflake User) where + mention = mentionSnowflake "@" + +instance Mentionable (Snowflake Member) where + mention = mentionSnowflake "@" + +instance Mentionable (Snowflake Channel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake TextChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake VoiceChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake Category) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake GuildChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake DMChannel) where + mention = mentionSnowflake "#" + +instance Mentionable (Snowflake Role) where + mention = mentionSnowflake "@&" + +instance Mentionable User where + mention = mentionSnowflake "@" . getID @User + +instance Mentionable Member where + mention = mentionSnowflake "@" . getID @Member + +instance Mentionable Channel where + mention = mentionSnowflake "#" . getID @Channel + +instance Mentionable TextChannel where + mention = mentionSnowflake "#" . getID @TextChannel + +instance Mentionable VoiceChannel where + mention = mentionSnowflake "#" . getID @VoiceChannel + +instance Mentionable Category where + mention = mentionSnowflake "#" . getID @Category + +instance Mentionable GuildChannel where + mention = mentionSnowflake "#" . getID @GuildChannel + +instance Mentionable DMChannel where + mention = mentionSnowflake "#" . getID @DMChannel + +instance Mentionable Role where + mention = mentionSnowflake "@&" . getID @Role + +-- | Turn a regular 'Message' into a 'MessageReference' +asReference :: + -- | The message to reply to + Message -> + -- | If discord should error when replying to deleted messages + Bool -> + MessageReference +asReference msg = + MessageReference + (Just $ getID @Message msg) + (Just $ getID @Channel msg) + (msg ^. #guildID) diff --git a/Calamity/Utils/Permissions.hs b/Calamity/Utils/Permissions.hs new file mode 100644 --- /dev/null +++ b/Calamity/Utils/Permissions.hs @@ -0,0 +1,129 @@ +-- | Permission utilities +module Calamity.Utils.Permissions ( + basePermissions, + applyOverwrites, + PermissionsIn (..), + PermissionsIn' (..), +) where + +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 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 + +overwrites :: GuildChannel -> SM.SnowflakeMap Overwrite +overwrites (GuildTextChannel c) = c ^. #permissionOverwrites +overwrites (GuildVoiceChannel c) = c ^. #permissionOverwrites +overwrites (GuildCategory c) = c ^. #permissionOverwrites +overwrites _ = SM.empty + +-- | Apply any 'Overwrite's for a 'GuildChannel' onto some 'Permissions' +applyOverwrites :: GuildChannel -> Member -> Permissions -> Permissions +applyOverwrites c m p + | p .<=. administrator = allFlags + | otherwise = + let everyoneOverwrite = 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 + -- | Calculate a 'Member'\'s 'Permissions' in something + -- + -- If permissions could not be calculated because something couldn't be found + -- in the cache, this will return an empty set of permissions. Use + -- 'permissionsIn'' if you want to handle cases where something might not exist + -- in cache. + permissionsIn :: a -> Member -> Permissions + +-- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites +instance PermissionsIn (Guild, GuildChannel) where + permissionsIn (g, c) m = applyOverwrites c m $ basePermissions g m + +-- | A 'Member'\'s 'Permissions' in a guild are just their roles +instance PermissionsIn Guild where + 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 +-} +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 + +-- | A 'Member'\'s 'Permissions' in a guild are just their roles +instance PermissionsIn' Guild where + permissionsIn' g (getID @User -> uid) = do + m <- upgrade (getID @Guild g, coerceSnowflake @_ @Member uid) + case m of + 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 +-} +instance PermissionsIn' (Snowflake GuildChannel) where + permissionsIn' cid u = do + c <- upgrade cid + case c of + 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 +-} +instance PermissionsIn' (Snowflake Guild) where + permissionsIn' gid u = do + g <- upgrade gid + case g of + Just g' -> permissionsIn' g' u + Nothing -> pure noFlags diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,332 @@ # Changelog for Calamity +## 0.12.1.0 + ++ Fixed build with Aeson 2.2+ @L0neGamer ++ Fix ToJSON ChannelType instances @MorrowM ++ Bumped crypton-connection bounds from <0.4 to <0.5 + +## 0.12.0.0 + ++ Field names in `Calamity.HTTP.Webhook` were mistakenly `username` instead of + the required `name`, these fields were renamed to be correct. (Reported by @MorrowM) + +## 0.11.0.0 + ++ Added support for Aeson 2.2 @Miezhiko ++ Support MTL 2.3+ @Miezhiko + +## 0.10.0.0 + ++ Updated `CreateMessageAttachment.content` to be a `Network.HTTP.Client.RequestBody` + to allow for easy streaming of uploads + +## 0.9.0.0 + ++ Require tls >= 1.7 ++ Bump dependencies to support tls-1.7 + +## 0.7.1.0 + ++ Fix ratelimits being effectively broken (succ -> pred) + +## 0.7.0.1 + ++ Fix accidental semver breakage + +## 0.7.0.0 + ++ Added the `CDNAsset` typeclass for resolving CDN asset links and fetching + them. ++ Added the module `Calamity.Types.Model.Avatar` with the types `Avatar` and + `MemberAvatar` ++ Changed the `avatar` field of `User` and `Member` to be `Avatar` (the default + avatar will be fetched if the user does not have one set). ++ Added the field `banner` to `User` and `Member` with type `Maybe UserBanner`. ++ Added the field `accentColour` to `User` and `Member` with type `Maybe (Colour Double)`. ++ Added the field `locale` to `User` and `Member` with type `Maybe Text`. ++ Added the field `Member.memberAvatar` with type `Text`. (discord limitation, + the guild id is needed to construct the member's guild avatar url, but discord + doesn't attach the guild id to the member...) ++ Added the type `RoleIcon` to `Calamity.Types.Model.Guild.Role`. ++ Added the field `Role.icon` with type `RoleIcon`. ++ Added the field `Role.emoji` with type `RawEmoji`. ++ Added the types `GuildIcon`, `GuildSplash`, `GuildDiscoverySplash`, + `GuildBanner` to `Calamity.Types.Model.Guild.Guild`. ++ Changed the type of `Guild.icon` to `Maybe GuildIcon`. ++ Changed the type of `Guild.splash` to `Maybe GuildSplash`. ++ Added the field `Guild.discoverySplash` with type `Maybe + GuildDiscoverySplash`. ++ Added the field `Guild.banner` with type `Maybe GuildBanner`. + + +## 0.6.0.0 + ++ Updated the events `GuildMemberAddEvt`, `GuildMemberRemoveEvt`, and + `GuildMemberUpdateEvt` to include the relevant `Guild`. + +```hs +EHType 'GuildMemberAddEvt = (Guild, Member) +EHType 'GuildMemberRemoveEvt = (Guild, Member) +EHType 'GuildMemberUpdateEvt = (Guild, Member, Member) +``` + +## 0.5.0.0 + ++ Replaced lens with optics internally, you should use optics for field labels now. ++ Generic instances have been removed from library data types. ++ Internally, all aeson instances are manually implemented now, + instead of using generic. Expect a 5x improvement in compile time. ++ The `game` field on `StatusUpdateData` was changed to `activities :: [Activity]` + +## 0.4.0.0 + ++ DSL functions no longer use a concrete effect list prefix. + +## 0.3.0.0 + ++ The discord api version has been moved from v9 to v10. ++ Added support for interactions and views with `Calamity.Interactions`. ++ Some more effects have been put in, `RatelimitEff` and `TokenEff`, causing + changes to `BotC`, `SetupEff`. ++ The HTTP client can now be used without a `Client` instance. ++ The `GuildMemberAdd` event now includes the guild id of the member. ++ The `InteractionCreate` event has been added. ++ Adding attachments to messages has now been reworked, and `TFile` has been + replaced with `CreateMessageAttachment`. ++ The `file` attribute of `CreateMessageOptions` has been removed and replaced + with `attachments :: Maybe [CreateMessageAttachment]`. ++ The `embed` attribute of `CreateMessageOptions` has been replaced with `embeds + :: Maybe [Embed]`. ++ The `components :: Maybe [Component]` field has been added to + `CreateMessageOptions`. ++ `editMessageEmbed` has been replaced with `editMessageEmbeds`. ++ Added `Calamity.HTTP.Channel.editMessageComponents`. ++ Added `Calamity.HTTP.Guild.SearchGuildMembers`. ++ `Calamity.HTTP.Guild.GetGuildBans` now has a `GetGuildBansOptions` parameter. ++ Added the module `Calamity.HTTP.Interaction`. ++ Added the modules `Calamity.Interactions`, + `Calamity.Interactions.{Eff,Utils,View}`. ++ Fully fleshed out `Calamity.Types.Model.Channel.Component`. ++ Removed `stickers` from `Message`. ++ Removed the `guildID` field from `Member`. + +## 0.2.0.2 + ++ Dependency bump + +## 0.2.0.1 + ++ Fix a bug causing member objects sent alongside messages to not parse correctly. + +## 0.2.0.0 + ++ Remove all usages of lazy Text (except from typeclass instances) ++ Fix a bug that caused http request decoding to never select the `()` instance + for decoding the response (which meant endpoints that had empty responses + would always fail to parse). ++ Bumped the minimum version of aeson to 2.0 + +## 0.1.31.0 + ++ We now pass through the `.member` field of message create/update events to the + event handler. ++ The payload type of `MessageCreateEvt` has changed from `Message` to + `(Message, Maybe User, Maybe Member)`. ++ The payload type of `MessageUpdateEvt` has changed from `(Message, Message)` + to `(Message, Message, Maybe User, Maybe Member)`. ++ The payload type of `RawMessageUpdateEvt` has changed from `UpdatedMessage` to + `(UpdatedMessage, Maybe User, Maybe Member)`. ++ The provided `ConstructContext` effect handlers have changed from handling + `ConstructContext Message ...` to `ConstructContext (Message, User, Maybe + Member) ...`. ++ `FullContext` now uses the member passed with the message create event if + available. ++ `LightContext` now has a `.member` parameter, which is the member passed with + the message create event if available. The `userID` field has also been + replaced with `user :: User`. ++ `CommandNotFound` now contains the `User` and `Maybe Member` of the message + create event that triggered it. + +## 0.1.30.4 + ++ The `status` field of `StatusUpdateData` has been changed from `Text` to + `StatusType`. ++ Removed the redundant `Typeable` constraint from `BotC` and `runBotIO`, etc. ++ Added the `runBotIO''` function which gives more control over the internal + state effects. + +## 0.1.30.3 + ++ Added models for interactions and components + (these are still WIP in this version). ++ The 'types' help no longer shows in command help if the command has + no parameters. ++ Added a HasID instance for FullContext and LightContext types. + +## 0.1.30.2 + ++ Removed all the orphan instances from the library. ++ Removed the export of `CalamityCommands.Handler` from `Calamity.Commands`. ++ Added the export of `Calamity.Commands.Types` from `Calamity.Commands`. ++ Fixed some parameter parser instances causing type inference to fail + ([#48](https://github.com/simmsb/calamity/pull/48)). + +## 0.1.30.1 + ++ Removed the re-export of `CalamityCommands.ParsePrefix` from Calamity.Commands. ++ Added the `Calamity.Commands.Utils.useConstantPrefix` method. + +## 0.1.30.0 + ++ Removed the `Symbol` parameter of custom events, instead of `'CustomEvt + @"command-error" @(FullContext, CommandError)` it is now `'CustomEvt + (CtxCommandError FullContext)`, etc. ++ Added `embedFooter`, `embedImage`, `embedThumbnail`, `embedAuthor`, and + `embedField` utility functions. ++ Added `Default` instances for `EmbedAuthor`. ++ Corrected the nullability of `EmbedImage`, `EmbedThumbnail`, `EmbedVideo`, and + `EmbedProvider`. ++ Changed the command parameter machinery to hold more info about parameters. ++ Added a 'type cheatsheet' thing to command help in the default help command. ++ Calamity now uses and re-exports the Calamity-Commands package instead of + having all the code duplicated. ++ An extra effect now needs to be handled for commands: `ConstructContext`, this + also allows you to change which context your bot uses. ++ `Calamity.Commands.Context.Context` has been removed, instead use + `FullContext`, `LightContext`, or make your own. + +## 0.1.29.0 + ++ The minimum version of `base` has been upped to `4.13` as the library fails to + build on ghc-8.6 ++ The minimum version of `polysemy` has been upped to 1.5 ++ The upper bound of `lens` has been bumped to 6 ++ The library now compiles with ghc-9 + +## 0.1.28.5 + ++ Use the correct HTTP method for `ModifyChannel` + +## 0.1.28.4 + ++ Rework the route handling so that the bucket keys for emoji routes work + properly + +## 0.1.28.3 + ++ Fix HTTP responses from discord that don't have ratelimit info being treated + as errors. + +## 0.1.28.2 + ++ Correct the emoji HTTP endpoints to work with `CustomEmoji`s ++ Rework the ratelimit implementation more + +## 0.1.28.1 + ++ Rework the ratelimit implementation to use X-Ratelimit-Bucket ++ Fix incorrect interpretation of the retry-after for 429s + +## 0.1.28.0 + ++ Added support for message types 19 (reply) and 20 (application command) ++ Added the `MessageReference` type ++ Changed the type of `Message.webhookID` to `Snowflake Webhook` ++ Added the `activity`, `application`, `messageReference`, `flags`, `stickers`, + `referencedMessage`, and `interaction` fields to messages. ++ Added `messageReference` as a parameter of `CreateMessageOptions` ++ Added `repliedUser` as a parameter of `AllowedMentions` ++ Fixed `CreateMessage` not actually sending the `allowedMentions` key ++ Added the `CrosspostMessage` route ++ Added a `ToMessage` instance for `MessageReference` ++ Added a `reply` function to `Calamity.Types.Tellable` that replies to a given + message in the same channel as the message ++ Added an `asReference` function to `Calamity.Utils.Message` + +## 0.1.27.0 + ++ Change the structure of `Reaction` to be `(count, me, emoji)` ++ The previous structure of `Reaction` is now known as `ReactionEvtData` ++ The type of `MessageReactionAddEvt` and `MessageReactionRemoveEvt` events has + been changed from `(Message, Reaction)` to `(Message, User, Channel, + RawEmoji)` ++ The type of `RawMessageReactionAddEvt` and `RawMessageReactionRemoveEvt` + events has been changed from `Reaction` to `ReactionEvtData` ++ More fixes to HTTP ++ When parsing guilds, channels/members/ and presences that cannot be parsed are + (silently) ignored instead of causing parsing of the guild to fail. + +## 0.1.26.1 + ++ Quick fix of GetChannelMessages + +## 0.1.26.0 + ++ `GetChannelMessages` now has an extra parameter to allow the `limit` option to + be applied at the same time as the other filters. ++ `ChannelMessagesQuery` has been renamed to `ChannelMessagesFilter`. ++ The `ChannelMessagesLimit` type has been introduced. + +## 0.1.25.1 + ++ Add `Upgradeable` instances for `VoiceChannnel`, `DMChannel`_, `GroupChannel`, + `TextChannel`, and `Category`. + +## 0.1.25.0 + ++ Changed how `ModifyGuildMemberData`, and `ModifyGuildRoleData` are implemented + to allow for the parameters to be optional and nullable. ++ Changed `EditMessage` to use `EditMessageData` instead of `Maybe Text -> Maybe + Embed`, allowing for the parameters to be optional and nullable. + +## 0.1.24.2 + ++ Add event handlers for voice state update events: `'VoiceStateUpdateEvt` ++ Apply some fixes for a few memory leaks + +## 0.1.24.1 + ++ Fix some memory leaks + +## 0.1.24.0 + ++ Switch from using Wreq to Req ++ The `session` parameter has been removed from `runBotIO'` ++ Add an `Upgradeable` instance for `Role`s ++ Add a command `Parser` instance for `Role`s + +## 0.1.23.1 + ++ Fix some more json parsing issues + +## 0.1.23.0 + ++ The `roles` field was incorrectly present on the `PresenceUpdate` type, that + field has been removed. ++ The `game` field on `Presence` was changed to `activities :: [Activity]` + +## 0.1.22.1 + ++ Bump some upper bounds ++ Fix parsing of members from GetGuildMember ++ Make game field in Presence correctly optional ++ Make roles field in Presence updates correctly optional (internal) + +## 0.1.22.0 + +* Update to gateway/http endpoint v8. +* Updated the message types. +* Added `defaultIntents`, which is all but the privileged intents, also a + Data.Default instance. +* `runBotIO` and `runBotIO'` now always take an `Intents` parameter. +* Users are cached from messages, as well as member create events. +* Fix `Overwrite`s having an incorrect `type_` field. + +## 0.1.21.0 + +* Fix ToJSON instance for `RawEmoji` + ## 0.1.20.1 * Documentation improvements. @@ -29,15 +356,15 @@ * Add raw message events: `RawMessageUpdateEvt`, `RawMessageDeleteEvt`, `RawMessageDeleteBulkEvt`, `RawMessageReactionAddEvt`, `RawMessageReactionRemoveEvt`, `RawMessageReactionRemoveAllEvt`. - + * Fixed bulk message deletes firing a message delete per deleted message, instead of a bulk message delete event (I'm not sure how I did that). - + * Add `animated` field to `Partial Emoji`s. * Make show instances for `Partial Emoji` and `RawEmoji` show to their discord representation. - + ## 0.1.17.2 *2020-07-04* diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,11 @@

Calamity

- - - - -

Hackage - Gitlab pipeline status - License + Build Status + License Hackage-Deps + Discord Invite

Calamity is a Haskell library for writing discord bots, it uses @@ -17,6 +13,10 @@ handling effects, allowing you to pick and choose how to handle certain features of the library. +If you're looking for something with a less complicated interface, you might +want to take a look at +[discord-haskell](https://github.com/aquarial/discord-haskell). + The current customisable effects are: * Cache: The default cache handler keeps the cache in memory, however you could @@ -26,139 +26,278 @@ useful things, by default these are not used (and cost nothing), but could be combined with [Prometheus](https://hackage.haskell.org/package/prometheus). An example of using prometheus as the metrics handler can be found - [here](https://github.com/nitros12/calamity-example). + [here](https://github.com/simmsb/calamity-example). +* Logging: The [di-polysemy](https://hackage.haskell.org/package/di-polysemy) + library is used to allow the logging effect to be customized, or disabled. + # Docs You can find documentation on hackage at: https://hackage.haskell.org/package/calamity +There's also a good blog post that covers the fundamentals of writing a bot with +the library, you can read it here: +https://morrowm.github.io/posts/2021-04-29-calamity.html + # Examples -Some example projects can be found at: -- [nitros12/calamity-example](https://github.com/nitros12/calamity-example): An extended example of the snippet below, shows use of metrics. -- [nitros12/calamity-bot](https://github.com/nitros12/calamity-bot): Uses a database, showing modularisation of groups/commands. +Here's a list of projects that use calamity: + +- [simmsb/calamity-bot](https://github.com/simmsb/calamity-bot): Uses a database, showing modularization of groups/commands. +- [MorrowM/pandabot-discord](https://github.com/MorrowM/pandabot-discord): Uses a database, performs member role management, etc. +- [MorrowM/calamity-tutorial](https://github.com/MorrowM/calamity-tutorial): A bare minimum bot. +- [koluacik/gundyr](https://github.com/koluacik/gundyr): An admin bot that does role assignment, etc. +(Feel free to contact me via the discord server, or email me via +ben@bensimms.moe if you've written a bot using calamity, or don't want your +project listed here) + ``` haskell +#!/usr/bin/env cabal +{- cabal: + build-depends: + base >= 4.13 && < 5 + , calamity >= 0.10.0.0 + , optics >= 0.4.1 && < 0.5 + , di-polysemy ^>= 0.2 + , di >= 1.3 && < 2 + , df1 >= 0.3 && < 0.5 + , di-core ^>= 1.0.4 + , polysemy >= 1.5 && <2 + , polysemy-plugin >= 0.3 && <0.5 + , stm >= 2.5 && <3 + , text-show >= 3.8 && <4 + , http-client ^>= 0.7 +-} + +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} - {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -module Main where +module Main (main) where -import Calamity -import Calamity.Cache.InMemory -import Calamity.Commands -import qualified Calamity.Commands.Context as CommandContext -import Calamity.Metrics.Noop +import Calamity +import Calamity.Cache.InMemory +import Calamity.Commands +import Calamity.Commands.Context (FullContext, useFullContext) +import Calamity.Interactions qualified as I +import Calamity.Metrics.Noop +import Calamity.Utils.CDNUrl (assetHashFile) +import Control.Concurrent +import Control.Monad +import Data.Foldable (for_) +import Data.Text qualified as T +import Di qualified +import DiPolysemy qualified as DiP +import Optics +import Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.State qualified as P +import System.Environment (getEnv) +import TextShow +import Network.HTTP.Client (RequestBody(RequestBodyLBS)) -import Control.Concurrent -import Control.Concurrent.STM.TVar -import Control.Lens -import Control.Monad +data MyViewState = MyViewState + { numOptions :: Int + , selected :: Maybe T.Text + } -import Data.Text.Lazy ( Text, fromStrict ) -import Data.Text.Strict.Lens +$(makeFieldLabelsNoPrefix ''MyViewState) -import qualified Di -import qualified DiPolysemy as DiP +main :: IO () +main = do + token <- T.pack <$> getEnv "BOT_TOKEN" + Di.new $ \di -> + void + . P.runFinal + . P.embedToFinal + . DiP.runDiToIO di + . runCacheInMemory + . runMetricsNoop + . useConstantPrefix "!" + . useFullContext + $ runBotIO (BotToken token) defaultIntents + $ do + void . addCommands $ do + helpCommand + -- just some examples -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.AtomicState as P -import qualified Polysemy.Embed as P -import qualified Polysemy.Fail as P + command @'[User] "pfp" \ctx u -> do + Right pfp <- fetchAsset (u ^. #avatar) + let name = maybe "default.png" assetHashFile (u ^. #avatar % #hash) + file = CreateMessageAttachment name (Just "Your avatar") (Network.HTTP.Client.RequestBodyLBS pfp) + void $ tell ctx file + command @'[User] "utest" \ctx u -> do + void . tell @T.Text ctx $ "got user: " <> showt u + command @'[Named "u" User, Named "u1" User] "utest2" \ctx u u1 -> do + void . tell @T.Text ctx $ "got user: " <> showt u <> "\nand: " <> showt u1 + command @'[T.Text, Snowflake User] "test" \_ctx something aUser -> do + DiP.info $ "something = " <> showt something <> ", aUser = " <> showt aUser + group "testgroup" $ do + void $ command @'[[T.Text]] "test" \ctx l -> do + void . tell @T.Text ctx $ "you sent: " <> showt l + group "say" do + command @'[KleenePlusConcat T.Text] "this" \ctx msg -> do + void $ tell @T.Text ctx msg + command @'[] "explode" \_ctx -> do + Just _ <- pure Nothing + DiP.debug @T.Text "unreachable!" + command @'[] "bye" \ctx -> do + void $ tell @T.Text ctx "bye!" + stopBot -import Prelude hiding ( error ) + -- views! -import TextShow + command @'[] "components" \ctx -> do + let view options = do + ~(add, done) <- I.row do + add <- I.button ButtonPrimary "add" + done <- I.button ButtonPrimary "done" + pure (add, done) + s <- I.select options + pure (add, done, s) + let initialState = MyViewState 1 Nothing + s <- P.evalState initialState $ + I.runView (view ["0"]) (tell ctx) \(add, done, s) -> do + when add do + n <- P.gets (^. #numOptions) + let n' = n + 1 + P.modify' (#numOptions .~ n') + let options = map (T.pack . show) [0 .. n] + I.replaceView (view options) (void . I.edit) -data Counter m a where - GetCounter :: Counter m Int + when done do + finalSelected <- P.gets (^. #selected) + I.endView finalSelected + I.deleteInitialMsg + void . I.respond $ case finalSelected of + Just x -> "Thanks: " <> x + Nothing -> "Oopsie" -P.makeSem ''Counter + case s of + Just s' -> do + P.modify' (#selected ?~ s') + void I.deferComponent + Nothing -> pure () + P.embed $ print s -runCounterAtomic :: P.Member (P.Embed IO) r => P.Sem (Counter ': r) a -> P.Sem r a -runCounterAtomic m = do - var <- P.embed $ newTVarIO (0 :: Int) - P.runAtomicStateTVar var $ P.reinterpret (\case - GetCounter -> P.atomicState (\v -> (v + 1, v))) m + -- more views! -handleFailByLogging m = do - r <- P.runFail m - case r of - Left e -> DiP.error (e ^. packed) - _ -> pure () + command @'[] "cresponses" \ctx -> do + let view = I.row do + a <- I.button ButtonPrimary "defer" + b <- I.button ButtonPrimary "deferEph" + c <- I.button ButtonPrimary "deferComp" + d <- I.button ButtonPrimary "modal" + pure (a, b, c, d) -info, debug :: BotC r => Text -> P.Sem r () -info = DiP.info -debug = DiP.info + modalView = do + a <- I.textInput TextInputShort "a" + b <- I.textInput TextInputParagraph "b" + pure (a, b) -tellt :: (BotC r, Tellable t) => t -> Text -> P.Sem r (Either RestError Message) -tellt t m = tell t $ L.toStrict m + I.runView view (tell ctx) $ \(a, b, c, d) -> do + when a do + void I.defer + P.embed $ threadDelay 1000000 + void $ I.followUp @T.Text "lol" -main :: IO () -main = do - token <- view packed <$> getEnv "BOT_TOKEN" - Di.new $ \di -> - void . P.runFinal . P.embedToFinal . DiP.runDiToIO di . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" - $ runBotIO (BotToken token) $ do - addCommands $ do - helpCommand - command @'[User] "utest" $ \ctx u -> do - void $ tellt ctx $ "got user: " <> showtl u - command @'[Named "u" User, Named "u1" User] "utest2" $ \ctx u u1 -> do - void $ tellt ctx $ "got user: " <> showtl u <> "\nand: " <> showtl u1 - command @'[L.Text, Snowflake User] "test" $ \ctx something aUser -> do - info $ "something = " <> showt something <> ", aUser = " <> showt aUser - command @'[] "hello" $ \ctx -> do - void $ tellt ctx "heya" - group "testgroup" $ do - command @'[[L.Text]] "test" $ \ctx l -> do - void $ tellt ctx ("you sent: " <> showtl l) - command @'[] "count" $ \ctx -> do - val <- getCounter - void $ tellt ctx ("The value is: " <> showtl val) - group "say" $ do - command @'[KleenePlusConcat L.Text] "this" $ \ctx msg -> do - void $ tellt ctx msg - command @'[Snowflake Emoji] "etest" $ \ctx e -> do - void $ tellt ctx $ "got emoji: " <> showtl e - command @'[] "explode" $ \ctx -> do - Just x <- pure Nothing - debug "unreachable!" - command @'[] "bye" $ \ctx -> do - void $ tellt ctx "bye!" - stopBot - command @'[] "fire-evt" $ \ctx -> do - fire $ customEvt @"my-event" ("aha" :: L.Text, ctx ^. #message) - command @'[L.Text] "wait-for" $ \ctx s -> do - void $ tellt ctx ("waiting for !" <> s) - waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s)) - void $ tellt ctx ("got !" <> s) - react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of - "!say hi" -> replicateM_ 3 . P.async $ do - info "saying heya" - Right msg' <- tellt msg "heya" - info "sleeping" - P.embed $ threadDelay (5 * 1000 * 1000) - info "slept" - void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing - info "edited" - _ -> pure () - react @('CustomEvt "command-error" (CommandContext.Context, CommandError)) $ \(ctx, e) -> do - info $ "Command failed with reason: " <> showt e - case e of - ParseError n r -> void . tellt ctx $ "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```" - react @('CustomEvt "my-event" (L.Text, Message)) $ \(s, m) -> - void $ tellt m ("Somebody told me to tell you about: " <> s) + when b do + void I.deferEphemeral + P.embed $ threadDelay 1000000 + void $ I.followUpEphemeral @T.Text "lol" + + when c do + void I.deferComponent + P.embed $ threadDelay 1000000 + void $ I.followUp @T.Text "lol" + + when d do + void . P.async $ do + I.runView modalView (void . I.pushModal "lol") $ \(a, b) -> do + P.embed $ print (a, b) + void $ I.respond ("Thanks: " <> a <> " " <> b) + I.endView () + + react @('CustomEvt (CtxCommandError FullContext)) \(CtxCommandError ctx e) -> do + DiP.info $ "Command failed with reason: " <> showt e + case e of + ParseError n r -> + void . tell ctx $ + "Failed to parse parameter: " + <> codeline n + <> ", with reason: " + <> codeblock' Nothing r + CheckError n r -> + void . tell ctx $ + "The following check failed: " + <> codeline n + <> ", with reason: " + <> codeblock' Nothing r + InvokeError n r -> + void . tell ctx $ + "The command: " + <> codeline n + <> ", failed with reason: " + <> codeblock' Nothing r ``` + +## Disabling library logging + +The library logs on debug levels by default, if you wish to disable logging you +can do something along the lines of: + +``` haskell +import qualified Di +import qualified Df1 +import qualified Di.Core +import qualified DiPolysemy + +filterDi :: Di.Core.Di l Di.Path m -> Di.Core.Di l Di.Path m +filterDi = Di.Core.filter (\_ p _ -> Df1.Push "calamity" `notElem` p) + +Di.new $ \di -> +-- ... + . runDiToIO di + -- disable logs emitted by calamity + . DiPolysemy.local filterDi + . runBotIO + -- ... +``` + + +## Nix + +If you trust me, I have a [cachix](https://www.cachix.org/) cache setup at +`simmsb-calamity`. + +With cachix installed, you should be able to run `cachix use simmsb-calamity` to +add my cache to your list of caches. + +You can also just manually add the substituter and public key: + +``` +substituters = https://simmsb-calamity.cachix.org +trusted-public-keys = simmsb-calamity.cachix.org-1:CQsXXpwKsjSVu0BJFT/JSvy1j6R7rMSW2r3cRQdcuQM= +``` + +After this nix builds should just use the cache (I hope?) + +For an example of a bot built using nix, take a look at: +[simmsb/calamity-bot](https://github.com/simmsb/calamity-bot) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal.project b/cabal.project deleted file mode 100644 --- a/cabal.project +++ /dev/null @@ -1,7 +0,0 @@ --- Generated by stackage-to-hackage - -with-compiler: ghc - -packages: - ./ - diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -1,187 +1,237 @@ -cabal-version: 1.18 - --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: 55bf5727de4e0d34fab772f8f03176d91db899e03912214153fdfd0bf161eedc +cabal-version: 2.0 +name: calamity +version: 0.12.1.0 +synopsis: A library for writing discord bots in haskell +description: + Please see the README on GitHub at -name: calamity -version: 0.1.20.1 -synopsis: A library for writing discord bots in haskell -description: Please see the README on GitHub at -category: Network, Web -homepage: https://github.com/nitros12/calamity -bug-reports: https://github.com/nitros12/calamity/issues -author: Ben Simms -maintainer: ben@bensimms.moe -copyright: 2020 Ben Simms -license: MIT -license-file: LICENSE -tested-with: GHC == 8.8.3 -build-type: Simple +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.6.6 extra-source-files: - README.md - ChangeLog.md - cabal.project -extra-doc-files: - README.md + ChangeLog.md + README.md +extra-doc-files: README.md + source-repository head - type: git - location: https://github.com/nitros12/calamity + 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.AliasType - Calamity.Commands.Check - Calamity.Commands.Command - Calamity.Commands.CommandUtils - Calamity.Commands.Context - Calamity.Commands.Dsl - Calamity.Commands.Error - Calamity.Commands.Group - Calamity.Commands.Handler - Calamity.Commands.Help - Calamity.Commands.ParsePrefix - Calamity.Commands.Parser - 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.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.Internal.AesonThings - Calamity.Internal.BoundedStore - Calamity.Internal.ConstructorName - Calamity.Internal.IntColour - Calamity.Internal.LocalWriter - Calamity.Internal.RunIntoIO - Calamity.Internal.SnowflakeMap - 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.Channel - Calamity.Types.Model.Channel.Attachment - Calamity.Types.Model.Channel.ChannelType - 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.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.UnixTimestamp - Calamity.Types.Upgradeable - Calamity.Utils - Calamity.Utils.Colour - Calamity.Utils.Message - Calamity.Utils.Permissions - other-modules: - Paths_calamity - hs-source-dirs: - src - 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 - ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing + 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: + 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 + NoMonomorphismRestriction + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + ViewPatterns + + ghc-options: -funbox-strict-fields -Wall -fno-warn-name-shadowing build-depends: - aeson >=1.4 && <2 - , async >=2.2 && <3 - , base >=4.12 && <5 - , bytestring >=0.10 && <0.11 - , colour >=2.3.5 && <2.4 - , concurrent-extra >=0.7 && <0.8 - , 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.3 && <0.5 - , di-core >=1.0.4 && <1.1 - , di-polysemy >=0.2 && <0.3 - , exceptions >=0.10 && <0.11 - , fmt >=0.6 && <0.7 - , focus >=1.0 && <2 - , generic-lens >=2.0 && <3 - , generic-override >=0.0.0.0 && <0.0.1 - , generic-override-aeson >=0.0.0.0 && <0.0.1 - , hashable >=1.2 && <2 - , http-date >=0.0.8 && <0.1 - , http-types >=0.12 && <0.13 - , lens >=4.18 && <5 - , lens-aeson >=1.1 && <2 - , megaparsec >=8 && <9 - , mime-types >=0.1 && <0.2 - , mtl >=2.2 && <3 - , polysemy >=1.3 && <2 - , polysemy-plugin >=0.2 && <0.3 - , reflection >=2.1 && <3 - , 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 - , text-show >=3.8 && <4 - , time >=1.8 && <1.11 - , typerep-map >=0.3 && <0.4 - , unagi-chan >=0.4 && <0.5 - , unboxing-vector >=0.1 && <0.2 - , unordered-containers >=0.2 && <0.3 - , vector >=0.12 && <0.13 - , websockets >=0.12 && <0.13 - , wreq >=0.5 && <0.6 - , wuss >=1.1 && <2 - default-language: Haskell2010 + aeson >=2.1 && <2.3 + , aeson-optics >=1.2 && <2 + , async >=2.2 && <3 + , base >=4.13 && <5 + , bytestring >=0.10 && <0.13 + , calamity-commands >=0.4 && <0.5 + , colour >=2.3.5 && <2.4 + , concurrent-extra >=0.7 && <0.8 + , containers >=0.6 && <0.8 + , crypton-connection >=0.2.6 && <0.5 + , crypton-x509-system >=1.6.6 && <1.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.7 + , 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.2 + , text-show >=3.8 && <4 + , time >=1.8 && <1.15 + , tls >=1.7 && <3 + , 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.13 && <0.14 + + default-language: Haskell2010 diff --git a/src/Calamity.hs b/src/Calamity.hs deleted file mode 100644 --- a/src/Calamity.hs +++ /dev/null @@ -1,12 +0,0 @@ -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 diff --git a/src/Calamity/Cache/Eff.hs b/src/Calamity/Cache/Eff.hs deleted file mode 100644 --- a/src/Calamity/Cache/Eff.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# 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 - -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 - -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 - GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild) - -- | Get a 'GuildChannel' from the cache - GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel) - -- | Get all 'Guild's from the cache - 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 - GetDM :: Snowflake DMChannel -> CacheEff m (Maybe DMChannel) - -- | Get all 'DMChannel's from the cache - 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 - GetUser :: Snowflake User -> CacheEff m (Maybe User) - -- | Get all 'User's from the cache - 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 - IsUnavailableGuild :: Snowflake Guild -> CacheEff m Bool - -- | Get all 'UnavailableGuild's from the cache - 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 - GetMessage :: Snowflake Message -> CacheEff m (Maybe Message) - -- | Get all 'Message's from the cache - GetMessages :: CacheEff m [Message] - -- | Delete a 'Message' from the cache - DelMessage :: Snowflake Message -> CacheEff m () - -makeSem ''CacheEff - -updateBotUser :: P.Member CacheEff r => (User -> User) -> Sem r () -updateBotUser f = getBotUser >>= flip whenJust (setBotUser . f) - -updateGuild :: P.Member CacheEff r => Snowflake Guild -> (Guild -> Guild) -> Sem r () -updateGuild id f = getGuild id >>= flip whenJust (setGuild . f) - -updateDM :: P.Member CacheEff r => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r () -updateDM id f = getDM id >>= flip whenJust (setDM . f) - -updateUser :: P.Member CacheEff r => Snowflake User -> (User -> User) -> Sem r () -updateUser id f = getUser id >>= flip whenJust (setUser . f) - -updateMessage :: P.Member CacheEff r => Snowflake Message -> (Message -> Message) -> Sem r () -updateMessage id f = getMessage id >>= flip whenJust (setMessage . f) diff --git a/src/Calamity/Cache/InMemory.hs b/src/Calamity/Cache/InMemory.hs deleted file mode 100644 --- a/src/Calamity/Cache/InMemory.hs +++ /dev/null @@ -1,125 +0,0 @@ --- | A 'Cache' handler that operates in memory -module Calamity.Cache.InMemory - ( runCacheInMemory - , runCacheInMemory' - , runCacheInMemoryNoMsg ) where - -import Calamity.Cache.Eff -import qualified Calamity.Internal.BoundedStore as BS -import qualified Calamity.Internal.SnowflakeMap 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.Lens -import Control.Monad.State.Strict - -import Data.Foldable -import qualified Data.HashMap.Lazy as LH -import qualified Data.HashSet as LS -import Data.IORef - -import GHC.Generics - -import qualified Polysemy as P -import qualified Polysemy.AtomicState as P - -data Cache f = Cache - { user :: Maybe User - , guilds :: SM.SnowflakeMap Guild - , dms :: SM.SnowflakeMap DMChannel - , guildChannels :: LH.HashMap (Snowflake GuildChannel) Guild - , users :: SM.SnowflakeMap User - , unavailableGuilds :: LS.HashSet (Snowflake Guild) - , messages :: f (BS.BoundedStore Message) - } - deriving ( Generic ) - -type CacheWithMsg = Cache Identity -type CacheNoMsg = Cache (Const ()) - -emptyCache :: CacheWithMsg -emptyCache = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty (Identity $ BS.empty 1000) - -emptyCacheNoMsg :: CacheNoMsg -emptyCacheNoMsg = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty (Const ()) - -emptyCache' :: Int -> CacheWithMsg -emptyCache' msgLimit = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty (Identity $ BS.empty msgLimit) - --- | Run the cache in memory with a default message cache size of 1000 -runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a -runCacheInMemory m = do - var <- P.embed $ newIORef emptyCache - P.runAtomicStateIORef var $ P.reinterpret runCache' m - --- | Run the cache in memory with no messages being cached -runCacheInMemoryNoMsg :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a -runCacheInMemoryNoMsg m = do - var <- P.embed $ newIORef emptyCacheNoMsg - P.runAtomicStateIORef var $ P.reinterpret runCache' m - --- | Run the cache in memory with a configurable message cache limit -runCacheInMemory' :: P.Member (P.Embed IO) r => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a -runCacheInMemory' msgLimit m = do - var <- P.embed $ newIORef (emptyCache' msgLimit) - P.runAtomicStateIORef var $ P.reinterpret runCache' m - -runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a -runCache' act = P.atomicState' ((swap .) . runState $ runCache act) - -class MessageMod t where - setMessage' :: Message -> State t () - getMessage' :: Snowflake Message -> State t (Maybe Message) - getMessages' :: State t [Message] - delMessage' :: Snowflake Message -> State t () - -instance MessageMod CacheWithMsg where - setMessage' m = #messages . _Wrapped %= BS.addItem m - getMessage' mid = use (#messages . _Wrapped . at mid) - getMessages' = toList <$> use (#messages . _Wrapped) - delMessage' mid = #messages . _Wrapped %= sans mid - -instance MessageMod CacheNoMsg where - setMessage' _ = pure () - getMessage' _ = pure Nothing - getMessages' = pure [] - delMessage' _ = pure () - -runCache :: MessageMod (Cache t) => CacheEff m a -> State (Cache t) a - -runCache (SetBotUser u) = #user ?= u -runCache GetBotUser = use #user - -runCache (SetGuild g) = do - #guilds %= SM.insert g - #guildChannels %= LH.filter (\v -> getID @Guild v /= getID @Guild g) - #guildChannels %= LH.union (LH.fromList $ map (,g) (SM.keys (g ^. #channels))) -runCache (GetGuild gid) = use (#guilds . at gid) -runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid)) -runCache GetGuilds = SM.elems <$> use #guilds -runCache (DelGuild gid) = do - #guilds %= sans gid - #guildChannels %= LH.filter (\v -> getID @Guild v /= gid) - -runCache (SetDM dm) = #dms %= SM.insert dm -runCache (GetDM did) = use (#dms . at did) -runCache GetDMs = SM.elems <$> use #dms -runCache (DelDM did) = #dms %= sans did - -runCache (SetUser u) = #users %= SM.insert u -runCache (GetUser uid) = use (#users . at uid) -runCache GetUsers = SM.elems <$> use #users -runCache (DelUser uid) = #users %= sans uid - -runCache (SetUnavailableGuild gid) = #unavailableGuilds %= LS.insert gid -runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid) -runCache GetUnavailableGuilds = LS.toList <$> use #unavailableGuilds -runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid - -runCache (SetMessage m) = setMessage' m -runCache (GetMessage mid) = getMessage' mid -runCache GetMessages = getMessages' -runCache (DelMessage mid) = delMessage' mid diff --git a/src/Calamity/Client.hs b/src/Calamity/Client.hs deleted file mode 100644 --- a/src/Calamity/Client.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | Module containing the core client stuff -module Calamity.Client - ( module Calamity.Client.Client - , module Calamity.Client.Types - -- * Client stuff - -- $clientDocs - ) where - -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/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs deleted file mode 100644 --- a/src/Calamity/Client/Client.hs +++ /dev/null @@ -1,720 +0,0 @@ -{-# OPTIONS_GHC -Wno-name-shadowing #-} - --- | The client -module Calamity.Client.Client - ( react - , runBotIO - , runBotIO' - , stopBot - , sendPresence - , events - , fire - , waitUntil - , waitUntilM - , CalamityEvent(Dispatch, ShutDown) - , customEvt ) where - -import Calamity.Cache.Eff -import Calamity.Client.ShardManager -import Calamity.Client.Types -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Types -import Calamity.Gateway.Intents -import Calamity.HTTP.Internal.Ratelimit -import Calamity.Internal.ConstructorName -import Calamity.Internal.RunIntoIO -import qualified Calamity.Internal.SnowflakeMap as SM -import Calamity.Internal.Updateable -import Calamity.Internal.Utils -import Calamity.Metrics.Eff -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.Presence ( Presence(..) ) -import Calamity.Types.Model.User -import Calamity.Types.Snowflake -import Calamity.Types.Token -import Calamity.Types.LogEff - -import Control.Concurrent.Chan.Unagi -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Control.Exception ( SomeException ) -import Control.Lens hiding ( (<.>) ) -import Control.Monad - -import Data.Default.Class -import Data.Dynamic -import Data.Foldable -import Data.Generics.Product.Subtype -import Data.IORef -import Data.Maybe -import Data.Proxy -import qualified Data.Text as S -import Data.Time.Clock.POSIX -import Data.Typeable - -import qualified Di.Core as DC -import qualified Df1 -import qualified DiPolysemy as Di - -import Network.Wreq.Session ( Session, newAPISession ) - -import Fmt - -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 TextShow ( TextShow(showt) ) - -timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) -timeA m = do - start <- P.embed getPOSIXTime - res <- m - end <- P.embed getPOSIXTime - let duration = fromRational . toRational $ end - start - pure (duration, res) - - -newClient :: Token -> Session -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client -newClient token session initialDi = do - shards' <- newTVarIO [] - numShards' <- newEmptyMVar - rlState' <- newRateLimitState - (inc, outc) <- newChan - ehidCounter <- newIORef 0 - - pure $ Client shards' - numShards' - token - rlState' - inc - outc - ehidCounter - session - initialDi - --- | Create a bot, run your setup action, and then loop until the bot closes. -runBotIO :: forall r a. - (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) - => Token - -> P.Sem (SetupEff r) a - -> P.Sem r (Maybe StartupError) -runBotIO token setup = runBotIO' token Nothing Nothing Nothing setup - -resetDi :: BotC r => P.Sem r a -> P.Sem r a -resetDi m = do - initialDi <- P.asks (^. #initialDi) - Di.local (flip fromMaybe initialDi) m - --- | Create a bot, run your setup action, and then loop until the bot closes. --- --- This version allows you to specify the http session, initial status, and intents. -runBotIO' :: forall r a. - (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r)) - => Token - -> Maybe Session - -- ^ The HTTP session to use, defaults to 'newAPISession' - -> Maybe StatusUpdateData - -- ^ The initial status to send to the gateway - -> Maybe Intents - -- ^ The intents to send to the gateway - -> P.Sem (SetupEff r) a - -> P.Sem r (Maybe StartupError) -runBotIO' token session status intents setup = do - initialDi <- Di.fetch - session' <- maybe (P.embed newAPISession) pure session - client <- P.embed $ newClient token session' initialDi - handlers <- P.embed $ newTVarIO def - P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do - void $ Di.push "calamity-setup" setup - r <- shardBot status intents - case r of - Left e -> pure (Just e) - Right _ -> do - Di.push "calamity-loop" clientLoop - Di.push "calamity-stop" finishUp - pure Nothing - --- | Register an event handler, returning an action that removes the event handler from the bot. --- --- Refer to 'EventType' for what events you can register, and 'EHType' for the --- parameters the event handlers they receive. --- --- You'll probably want @TypeApplications@ and need @DataKinds@ enabled to --- specify the type of @s@. --- --- ==== Examples --- --- Reacting to every message: --- --- @ --- 'react' @\''MessageCreateEvt' '$' \msg -> 'print' '$' "Got message: " '<>' 'show' msg --- @ --- --- Reacting to a custom event: --- --- @ --- 'react' @(\''CustomEvt' "my-event" ('Data.Text.Text', 'Message')) $ \\(s, m) -> --- 'void' $ 'Calamity.Types.Tellable.tell' @'Data.Text.Text' m ("Somebody told me to tell you about: " '<>' s) --- @ --- --- ==== Notes --- --- This function is pretty bad for giving nasty type errors, --- since if something doesn't match then 'EHType' might not get substituted, --- which will result in errors about parameter counts mismatching. -react :: forall (s :: EventType) r. - (BotC r, ReactConstraints s) - => (EHType s -> (P.Sem r) ()) - -> P.Sem r (P.Sem r ()) -react handler = do - handler' <- bindSemToIO handler - ehidC <- P.asks (^. #ehidCounter) - id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i)) - let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler') - P.atomicModify (handlers <>) - pure $ removeHandler @s id' - -removeHandler :: forall (s :: EventType) r. (BotC r, RemoveEventHandler s) => Integer -> P.Sem r () -removeHandler id' = P.atomicModify (removeEventHandler (Proxy @s) id') - --- | Fire an event that the bot will then handle. --- --- ==== Examples --- --- Firing an event named \"my-event\": --- --- @ --- 'fire' '$' 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg) --- @ -fire :: BotC r => CalamityEvent -> P.Sem r () -fire e = do - inc <- P.asks (^. #eventsIn) - P.embed $ writeChan inc e - --- | Build a Custom CalamityEvent --- --- You'll probably want @TypeApplications@ to specify the type of @s@. --- --- The types of @s@ and @a@ must match up with the event handler you want to --- receive it. --- --- ==== Examples --- --- Building an event named \"my-event\": --- --- @ --- 'customEvt' @"my-event" ("aha" :: 'Data.Text.Text', msg) --- @ -customEvt :: forall s a. (Typeable s, Typeable a) => a -> CalamityEvent -customEvt x = Custom (typeRep $ Proxy @s) (toDyn x) - --- | Get a copy of the event stream. -events :: BotC r => P.Sem r (OutChan CalamityEvent) -events = do - inc <- P.asks (^. #eventsIn) - P.embed $ dupChan inc - --- | Wait until an event satisfying a condition happens, then returns it's --- parameters. --- --- The check function for this command is pure unlike 'waitUntilM' --- --- This is what it would look like with @s ~ \''MessageCreateEvt'@: --- --- @ --- 'waitUntil' :: ('Message' -> 'Bool') -> 'P.Sem' r 'Message' --- @ --- --- And for @s ~ \''MessageUpdateEvt'@: --- --- @ --- 'waitUntil' :: (('Message', 'Message') -> 'Bool') -> 'P.Sem' r ('Message', 'Message') --- @ --- --- ==== Examples --- --- Waiting for a message containing the text \"hi\": --- --- @ --- f = do msg \<\- 'waitUntil' @\''MessageCreateEvt' (\\m -> 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content) --- print $ msg ^. #content --- @ -waitUntil - :: forall (s :: EventType) r. - ( BotC r, ReactConstraints s) - => (EHType s -> Bool) - -> P.Sem r (EHType s) -waitUntil f = P.resourceToIOFinal $ do - result <- P.embed newEmptyMVar - P.bracket (P.raise $ react @s (checker result)) - P.raise - (const . P.embed $ takeMVar result) - where - checker :: MVar (EHType s) -> EHType s -> P.Sem r () - checker result args = do - when (f args) $ do - P.embed $ putMVar result args - --- | Wait until an event satisfying a condition happens, then returns it's --- parameters --- --- This is what it would look like with @s ~ \''MessageCreateEvt'@: --- --- @ --- 'waitUntilM' :: ('Message' -> 'P.Sem' r 'Bool') -> 'P.Sem' r 'Message' --- @ --- --- And for @s ~ \''MessageUpdateEvt'@: --- --- @ --- 'waitUntilM' :: (('Message', 'Message') -> 'P.Sem' r 'Bool') -> 'P.Sem' r ('Message', 'Message') --- @ --- --- ==== Examples --- --- Waiting for a message containing the text \"hi\": --- --- @ --- f = do msg \<\- 'waitUntilM' @\''MessageCreateEvt' (\\m -> ('debug' $ "got message: " <> 'showt' msg) >> ('pure' $ 'Data.Text.Lazy.isInfixOf' "hi" $ m ^. #content)) --- print $ msg ^. #content --- @ -waitUntilM - :: forall (s :: EventType) r. - ( BotC r, ReactConstraints s) - => (EHType s -> P.Sem r Bool) - -> P.Sem r (EHType s) -waitUntilM f = P.resourceToIOFinal $ do - result <- P.embed newEmptyMVar - P.bracket (P.raise $ react @s (checker result)) - P.raise - (const . P.embed $ takeMVar result) - where - checker :: MVar (EHType s) -> EHType s -> P.Sem r () - checker result args = do - res <- f args - when res $ do - P.embed $ putMVar result args - --- | Set the bot's presence on all shards. -sendPresence :: BotC r => StatusUpdateData -> P.Sem r () -sendPresence s = do - shards <- P.asks (^. #shards) >>= P.embed . readTVarIO - for_ shards $ \(inc, _) -> - P.embed $ writeChan inc (SendPresence s) - --- | Initiate shutting down the bot. -stopBot :: BotC r => P.Sem r () -stopBot = do - debug "stopping bot" - inc <- P.asks (^. #eventsIn) - P.embed $ writeChan inc ShutDown - -finishUp :: BotC r => P.Sem r () -finishUp = do - debug "finishing up" - shards <- P.asks (^. #shards) >>= P.embed . readTVarIO - for_ shards $ \(inc, _) -> - P.embed $ writeChan inc ShutDownShard - for_ shards $ \(_, shardThread) -> P.await shardThread - debug "bot has stopped" - --- | main loop of the client, handles fetching the next event, processing the --- event and invoking it's handler functions -clientLoop :: BotC r => P.Sem r () -clientLoop = do - outc <- P.asks (^. #eventsOut) - whileMFinalIO $ do - evt' <- P.embed $ readChan outc - case evt' of - Dispatch sid evt -> handleEvent sid evt >> pure True - Custom s d -> handleCustomEvent s d >> pure True - ShutDown -> pure False - debug "leaving client loop" - -handleCustomEvent :: forall r. BotC r => TypeRep -> Dynamic -> P.Sem r () -handleCustomEvent s d = do - debug $ "handling a custom event, s: " +|| s ||+ ", d: " +|| d ||+ "" - eventHandlers <- P.atomicGet - - let handlers = getCustomEventHandlers s (dynTypeRep d) eventHandlers - - for_ handlers (\h -> P.async . P.embed $ h d) - -catchAllLogging :: BotC r => P.Sem r () -> P.Sem r () -catchAllLogging m = do - r <- P.errorToIOFinal . P.fromExceptionSem @SomeException $ P.raise m - case r of - Right _ -> pure () - Left e -> debug $ "got exception: " +|| e ||+ "" - -handleEvent :: BotC r => Int -> DispatchData -> P.Sem r () -handleEvent shardID data' = do - debug "handling an event" - eventHandlers <- P.atomicGet - actions <- P.runFail $ do - evtCounter <- registerCounter "events_received" [("type", S.pack $ ctorName data'), ("shard", showt shardID)] - void $ addCounter 1 evtCounter - cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20..100] - (time, res) <- timeA $ resetDi $ handleEvent' eventHandlers data' - void $ observeHistogram time cacheUpdateHisto - pure res - - eventHandleHisto <- registerHistogram "event_handle" mempty [10, 20..100] - - case actions of - Right actions -> for_ actions $ \action -> P.async $ do - (time, _) <- timeA . catchAllLogging $ P.embed action - void $ observeHistogram time eventHandleHisto - Left err -> debug $ "Failed handling actions for event: " +| err |+ "" - -handleEvent' :: BotC r - => EventHandlers - -> DispatchData - -> P.Sem (P.Fail ': r) [IO ()] -handleEvent' eh evt@(Ready rd@ReadyData {}) = do - updateCache evt - pure $ map ($ rd) (getEventHandlers @'ReadyEvt eh) - -handleEvent' _ Resumed = pure [] - -handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do - updateCache evt - Just newChan <- DMChannel' <<$>> getDM (getID chan) - pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) - -handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do - updateCache evt - Just guild <- getGuild (getID chan) - Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan) - pure $ map ($ newChan) (getEventHandlers @'ChannelCreateEvt eh) - -handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do - Just oldChan <- DMChannel' <<$>> getDM (getID chan) - updateCache evt - Just newChan <- DMChannel' <<$>> getDM (getID chan) - pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) - -handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do - Just oldGuild <- getGuild (getID chan) - Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan) - updateCache evt - Just newGuild <- getGuild (getID chan) - Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan) - pure $ map ($ (oldChan, newChan)) (getEventHandlers @'ChannelUpdateEvt eh) - -handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do - Just oldGuild <- getGuild (getID chan) - Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan) - updateCache evt - pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) - -handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do - Just oldChan <- DMChannel' <<$>> getDM (getID chan) - updateCache evt - pure $ map ($ oldChan) (getEventHandlers @'ChannelDeleteEvt eh) - --- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do --- chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just) --- <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just) --- pure $ map (\f -> f chan lastPinTimestamp) (getEventHandlers @"channelpinsupdate" eh) - -handleEvent' eh evt@(GuildCreate guild) = do - isNew <- not <$> isUnavailableGuild (getID guild) - updateCache evt - Just guild <- getGuild (getID guild) - pure $ map ($ (guild, (if isNew then GuildCreateNew else GuildCreateAvailable))) - (getEventHandlers @'GuildCreateEvt eh) - -handleEvent' eh evt@(GuildUpdate guild) = do - Just oldGuild <- getGuild (getID guild) - updateCache evt - Just newGuild <- getGuild (getID guild) - pure $ map ($ (oldGuild, newGuild)) (getEventHandlers @'GuildUpdateEvt eh) - --- NOTE: Guild will be deleted in the new cache if unavailable was false -handleEvent' eh evt@(GuildDelete UnavailableGuild { id, unavailable }) = do - Just oldGuild <- getGuild id - updateCache evt - pure $ map ($ (oldGuild, (if unavailable then GuildDeleteUnavailable else GuildDeleteRemoved))) - (getEventHandlers @'GuildDeleteEvt eh) - -handleEvent' eh evt@(GuildBanAdd BanData { guildID, user }) = do - Just guild <- getGuild guildID - updateCache evt - pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanAddEvt eh) - -handleEvent' eh evt@(GuildBanRemove BanData { guildID, user }) = do - Just guild <- getGuild guildID - updateCache evt - pure $ map ($ (guild, user)) (getEventHandlers @'GuildBanRemoveEvt eh) - --- NOTE: we fire this event using the guild data with old emojis -handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) = do - Just guild <- getGuild guildID - updateCache evt - pure $ map ($ (guild, emojis)) (getEventHandlers @'GuildEmojisUpdateEvt eh) - -handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData { guildID }) = do - updateCache evt - Just guild <- getGuild guildID - pure $ map ($ guild) (getEventHandlers @'GuildIntegrationsUpdateEvt eh) - -handleEvent' eh evt@(GuildMemberAdd member) = do - updateCache evt - Just guild <- getGuild (getID member) - Just member <- pure $ guild ^. #members . at (getID member) - pure $ map ($ member) (getEventHandlers @'GuildMemberAddEvt eh) - -handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData { user, guildID }) = do - Just guild <- getGuild guildID - Just member <- pure $ guild ^. #members . at (getID user) - updateCache evt - pure $ map ($ member) (getEventHandlers @'GuildMemberRemoveEvt eh) - -handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData { user, guildID }) = do - Just oldGuild <- getGuild guildID - Just oldMember <- pure $ oldGuild ^. #members . at (getID user) - updateCache evt - Just newGuild <- getGuild guildID - Just newMember <- pure $ newGuild ^. #members . at (getID user) - pure $ map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) - -handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData { members, guildID }) = do - updateCache evt - Just guild <- getGuild guildID - let members' = guild ^.. #members . foldMap (at . getID) members . _Just - pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh) - -handleEvent' eh evt@(GuildRoleCreate GuildRoleData { guildID, role }) = do - updateCache evt - Just guild <- getGuild guildID - Just role' <- pure $ guild ^. #roles . at (getID role) - pure $ map ($ (guild, role')) (getEventHandlers @'GuildRoleCreateEvt eh) - -handleEvent' eh evt@(GuildRoleUpdate GuildRoleData { guildID, role }) = do - Just oldGuild <- getGuild guildID - Just oldRole <- pure $ oldGuild ^. #roles . at (getID role) - updateCache evt - Just newGuild <- getGuild guildID - Just newRole <- pure $ newGuild ^. #roles . at (getID role) - pure $ map ($ (newGuild, oldRole, newRole)) (getEventHandlers @'GuildRoleUpdateEvt eh) - -handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = do - Just guild <- getGuild guildID - Just role <- pure $ guild ^. #roles . at roleID - updateCache evt - pure $ map ($ (guild, role)) (getEventHandlers @'GuildRoleDeleteEvt eh) - -handleEvent' eh (InviteCreate d) = do - pure $ map ($ d) (getEventHandlers @'InviteCreateEvt eh) - -handleEvent' eh (InviteDelete d) = do - pure $ map ($ d) (getEventHandlers @'InviteDeleteEvt eh) - -handleEvent' eh evt@(MessageCreate msg) = do - updateCache evt - pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) - -handleEvent' eh evt@(MessageUpdate msg) = do - oldMsg <- getMessage (getID msg) - updateCache evt - newMsg <- getMessage (getID msg) - let rawActions = map ($ msg) (getEventHandlers @'RawMessageUpdateEvt eh) - let actions = case (oldMsg, newMsg) of - (Just oldMsg', Just newMsg') -> - map ($ (oldMsg', newMsg')) (getEventHandlers @'MessageUpdateEvt eh) - _ -> [] - pure $ rawActions <> actions - -handleEvent' eh evt@(MessageDelete MessageDeleteData { id }) = do - oldMsg <- getMessage id - updateCache evt - let rawActions = map ($ id) (getEventHandlers @'RawMessageDeleteEvt eh) - let actions = case oldMsg of - Just oldMsg' -> - map ($ oldMsg') (getEventHandlers @'MessageDeleteEvt eh) - _ -> [] - pure $ rawActions <> actions - -handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData { ids }) = do - messages <- catMaybes <$> traverse getMessage ids - updateCache evt - let rawActions = map ($ ids) (getEventHandlers @'RawMessageDeleteBulkEvt eh) - let actions = map ($ messages) (getEventHandlers @'MessageDeleteBulkEvt eh) - pure $ rawActions <> actions - -handleEvent' eh evt@(MessageReactionAdd reaction) = do - updateCache evt - msg <- getMessage (getID reaction) - let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionAddEvt eh) - let actions = case msg of - Just msg' -> - map ($ (msg', reaction)) (getEventHandlers @'MessageReactionAddEvt eh) - _ -> [] - pure $ rawActions <> actions - -handleEvent' eh evt@(MessageReactionRemove reaction) = do - msg <- getMessage (getID reaction) - updateCache evt - let rawActions = map ($ reaction) (getEventHandlers @'RawMessageReactionRemoveEvt eh) - let actions = case msg of - Just msg' -> - map ($ (msg', reaction)) (getEventHandlers @'MessageReactionRemoveEvt eh) - _ -> [] - pure $ rawActions <> actions - -handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = do - msg <- getMessage messageID - updateCache evt - let rawActions = map ($ messageID) (getEventHandlers @'RawMessageReactionRemoveAllEvt eh) - let actions = case msg of - Just msg' -> - map ($ msg') (getEventHandlers @'MessageReactionRemoveAllEvt eh) - _ -> [] - pure $ rawActions <> actions - -handleEvent' eh evt@(PresenceUpdate PresenceUpdateData { userID, presence = Presence { guildID } }) = do - Just oldGuild <- getGuild guildID - Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID) - updateCache evt - Just newGuild <- getGuild guildID - Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID) - let oldUser :: User = upcast oldMember - newUser :: User = upcast newMember - userUpdates = if oldUser /= newUser - then map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh) - else mempty - pure $ userUpdates <> map ($ (oldMember, newMember)) (getEventHandlers @'GuildMemberUpdateEvt eh) - -handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp }) = - case guildID of - Just gid -> do - Just guild <- getGuild gid - Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID) - pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh) - Nothing -> do - Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID) - pure $ map ($ (chan, userID, timestamp)) (getEventHandlers @'TypingStartEvt eh) - -handleEvent' eh evt@(UserUpdate _) = do - Just oldUser <- getBotUser - updateCache evt - Just newUser <- getBotUser - pure $ map ($ (oldUser, newUser)) (getEventHandlers @'UserUpdateEvt eh) - -handleEvent' _ e = fail $ "Unhandled event: " <> show e - -updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r () -updateCache (Ready ReadyData { user, guilds }) = do - setBotUser user - for_ (map getID guilds) setUnavailableGuild - -updateCache Resumed = pure () - -updateCache (ChannelCreate (DMChannel' chan)) = - setDM chan - -updateCache (ChannelCreate (GuildChannel' chan)) = - updateGuild (getID chan) (#channels %~ SM.insert chan) - -updateCache (ChannelUpdate (DMChannel' chan)) = - updateDM (getID chan) (update chan) - -updateCache (ChannelUpdate (GuildChannel' chan)) = - updateGuild (getID chan) (#channels . ix (getID chan) %~ update chan) - -updateCache (ChannelDelete (DMChannel' chan)) = - delDM (getID chan) - -updateCache (ChannelDelete (GuildChannel' chan)) = - updateGuild (getID chan) (#channels %~ sans (getID chan)) - -updateCache (GuildCreate guild) = do - isNew <- isUnavailableGuild (getID guild) - when isNew $ delUnavailableGuild (getID guild) - setGuild guild - for_ (SM.fromList (guild ^.. #members . traverse . super)) setUser - -updateCache (GuildUpdate guild) = - updateGuild (getID guild) (update guild) - -updateCache (GuildDelete UnavailableGuild { id, unavailable }) = - if unavailable - then setUnavailableGuild id - else delGuild id - -updateCache (GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) = - updateGuild guildID (#emojis .~ SM.fromList emojis) - -updateCache (GuildMemberAdd member) = do - setUser (member ^. super) - updateGuild (getID member) (#members . at (getID member) ?~ member) - -updateCache (GuildMemberRemove GuildMemberRemoveData { guildID, user }) = - updateGuild guildID (#members %~ sans (getID user)) - -updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles, user, nick }) = do - setUser user - updateGuild guildID (#members . ix (getID user) %~ (#roles .~ roles) . (#nick .~ nick)) - -updateCache (GuildMembersChunk GuildMembersChunkData { members }) = - traverse_ (updateCache . GuildMemberAdd) members - -updateCache (GuildRoleCreate GuildRoleData { guildID, role }) = - updateGuild guildID (#roles %~ SM.insert role) - -updateCache (GuildRoleUpdate GuildRoleData { guildID, role }) = - updateGuild guildID (#roles %~ SM.insert role) - -updateCache (GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = - updateGuild guildID (#roles %~ sans roleID) - -updateCache (MessageCreate msg) = setMessage msg - -updateCache (MessageUpdate msg) = - updateMessage (getID msg) (update msg) - -updateCache (MessageDelete MessageDeleteData { id }) = delMessage id - -updateCache (MessageDeleteBulk MessageDeleteBulkData { ids }) = - for_ ids delMessage - -updateCache (MessageReactionAdd reaction) = - updateMessage (getID reaction) (#reactions %~ cons reaction) - -updateCache (MessageReactionRemove reaction) = - updateMessage (getID reaction) (#reactions %~ filter (\r -> r ^. #emoji /= reaction ^. #emoji)) - -updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = - updateMessage messageID (#reactions .~ mempty) - -updateCache (PresenceUpdate PresenceUpdateData { userID, roles, presence }) = - updateGuild (getID presence) ((#members . at (coerceSnowflake userID) . _Just . #roles .~ roles) - . (#presences . at userID ?~ presence)) - -updateCache (UserUpdate user) = setBotUser user - --- we don't handle group channels currently -updateCache (ChannelCreate (GroupChannel' _)) = pure () -updateCache (ChannelUpdate (GroupChannel' _)) = pure () -updateCache (ChannelDelete (GroupChannel' _)) = pure () - --- these don't modify state -updateCache (GuildBanAdd _) = pure () -updateCache (GuildBanRemove _) = pure () -updateCache (GuildIntegrationsUpdate _) = pure () -updateCache (TypingStart _) = pure () -updateCache (ChannelPinsUpdate _) = pure () -updateCache (WebhooksUpdate _) = pure () -updateCache (InviteCreate _) = pure () -updateCache (InviteDelete _) = pure () - --- we don't handle voice state currently -updateCache (VoiceStateUpdate _) = pure () -updateCache (VoiceServerUpdate _) = pure () diff --git a/src/Calamity/Client/ShardManager.hs b/src/Calamity/Client/ShardManager.hs deleted file mode 100644 --- a/src/Calamity/Client/ShardManager.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | Contains stuff for managing shards -module Calamity.Client.ShardManager - ( shardBot ) where - -import Calamity.Client.Types -import Calamity.Gateway -import Calamity.HTTP -import Calamity.Internal.Utils - -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Control.Lens -import Control.Monad - -import Data.Traversable - -import Fmt - -import Polysemy ( Sem ) -import qualified Polysemy.Fail as P -import qualified Polysemy as P -import qualified Polysemy.Reader as P - -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft f (Left a) = Left $ f a -mapLeft _ (Right b) = Right b - --- | Connects the bot to the gateway over n shards -shardBot :: BotC r => Maybe StatusUpdateData -> Maybe Intents -> Sem r (Either StartupError ()) -shardBot initialStatus intents = (mapLeft StartupError <$>) . P.runFail $ do - numShardsVar <- P.asks numShards - shardsVar <- P.asks shards - - hasShards <- P.embed $ not . null <$> readTVarIO shardsVar - when hasShards $ fail "don't use shardBot on an already running bot." - - token <- P.asks Calamity.Client.Types.token - inc <- P.asks (^. #eventsIn) - - Right gateway <- invoke GetGatewayBot - - let numShards' = gateway ^. #shards - let host = gateway ^. #url - P.embed $ putMVar numShardsVar numShards' - - info $ "Number of shards: " +| numShards' |+ "" - - shards <- for [0 .. numShards' - 1] $ \id -> - newShard host id numShards' token initialStatus intents inc - - P.embed . atomically $ writeTVar shardsVar shards - --- | Connects the bot to the gateway over 1 shard (userbot) --- shardUserBot :: BotM () --- shardUserBot = do --- numShardsVar <- asks numShards --- shardsVar <- asks shards - --- hasShards <- liftIO $ (not . null) <$> readTVarIO shardsVar --- when hasShards $ fail "don't use shardUserBot on an already running bot." - --- token <- asks Calamity.Client.Types.token --- eventQueue <- asks eventQueue --- logEnv <- askLog - --- gateway <- aa <$> invoke GetGateway - --- let host = gateway ^. #url --- liftIO $ putMVar numShardsVar 1 - --- liftIO $ do --- shard <- newShard host 0 1 token logEnv eventQueue --- atomically $ writeTVar shardsVar [shard] diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs deleted file mode 100644 --- a/src/Calamity/Client/Types.hs +++ /dev/null @@ -1,353 +0,0 @@ --- | Types for the client -module Calamity.Client.Types - ( Client(..) - , StartupError(..) - , EventType(..) - , GuildCreateStatus(..) - , GuildDeleteStatus(..) - , EHType - , BotC - , SetupEff - , ReactConstraints - , EventHandlers(..) - , InsertEventHandler(..) - , RemoveEventHandler(..) - , getEventHandlers - , getCustomEventHandlers ) where - -import Calamity.Cache.Eff -import Calamity.Gateway.DispatchEvents ( CalamityEvent(..), InviteCreateData, InviteDeleteData, ReadyData ) -import Calamity.Gateway.Types ( ControlMessage ) -import Calamity.HTTP.Internal.Types -import Calamity.Metrics.Eff -import Calamity.Types.LogEff -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Channel.UpdatedMessage -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Token -import Calamity.Types.UnixTimestamp -import Calamity.Types.Snowflake - -import Control.Concurrent.Async -import Control.Concurrent.Chan.Unagi -import Control.Concurrent.MVar -import Control.Concurrent.STM.TVar - -import Data.Default.Class -import Data.Dynamic -import qualified Data.HashMap.Lazy as LH -import Data.IORef -import Data.Maybe -import Data.Time -import qualified Data.TypeRepMap as TM -import Data.TypeRepMap ( TypeRepMap, WrapTypeable(..) ) -import Data.Typeable -import Data.Void - -import Network.Wreq.Session ( Session ) - -import GHC.Exts ( fromList ) -import GHC.Generics - -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.AtomicState as P -import qualified Polysemy.Reader as P - -import qualified TextShow.Generic as TSG -import TextShow -import qualified Df1 as Df1 -import qualified Di.Core as DC - -data Client = Client - { shards :: TVar [(InChan ControlMessage, Async (Maybe ()))] - , numShards :: MVar Int - , token :: Token - , rlState :: RateLimitState - , eventsIn :: InChan CalamityEvent - , eventsOut :: OutChan CalamityEvent - , ehidCounter :: IORef Integer - , session :: Session - , initialDi :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message) - } - deriving ( Generic ) - -type BotC r = - ( P.Members '[LogEff, MetricEff, CacheEff, P.Reader Client, - P.AtomicState EventHandlers, P.Embed IO, P.Final IO, P.Async] r - , Typeable r) - --- | A concrete effect stack used inside the bot -type SetupEff r = (P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) - --- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't --- worry about these since they are satisfied for any type @s@ can be -type ReactConstraints s = - ( InsertEventHandler s - , RemoveEventHandler s - ) - -newtype StartupError = StartupError String - deriving ( Show ) - --- | A Data Kind used to fire custom events -data EventType - = ReadyEvt - | ChannelCreateEvt - | ChannelUpdateEvt - | ChannelDeleteEvt - | ChannelpinsUpdateEvt - | GuildCreateEvt - | GuildUpdateEvt - | GuildDeleteEvt - | GuildBanAddEvt - | GuildBanRemoveEvt - | GuildEmojisUpdateEvt - | GuildIntegrationsUpdateEvt - | GuildMemberAddEvt - | GuildMemberRemoveEvt - | GuildMemberUpdateEvt - | GuildMembersChunkEvt - | GuildRoleCreateEvt - | GuildRoleUpdateEvt - | GuildRoleDeleteEvt - | InviteCreateEvt - | InviteDeleteEvt - | MessageCreateEvt - | MessageUpdateEvt - -- ^ Fired when a cached message is updated, use 'RawMessageUpdateEvt' to see - -- updates of uncached messages - | RawMessageUpdateEvt - -- ^ Fired when a message is updated - | MessageDeleteEvt - -- ^ Fired when a cached message is deleted, use 'RawMessageDeleteEvt' to see - -- deletes of uncached messages. - -- - -- Does not include messages deleted through bulk deletes, use - -- 'MessageDeleteBulkEvt' for those - | RawMessageDeleteEvt - -- ^ Fired when a message is deleted. - -- - -- Does not include messages deleted through bulk deletes, use - -- 'RawMessageDeleteBulkEvt' for those - | MessageDeleteBulkEvt - -- ^ Fired when messages are bulk deleted. Only includes cached messages, use - -- 'RawMessageDeleteBulkEvt' to see deletes of uncached messages. - | RawMessageDeleteBulkEvt - -- ^ Fired when messages are bulk deleted. - | MessageReactionAddEvt - -- ^ Fired when a reaction is added to a cached message, use - -- 'RawMessageReactionAddEvt' to see reactions on uncached messages. - | RawMessageReactionAddEvt - -- ^ Fired when a reaction is added to a message. - | MessageReactionRemoveEvt - -- ^ Fired when a reaction is removed from a cached message, use - -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages. - | RawMessageReactionRemoveEvt - -- ^ Fired when a reaction is removed from a message. - | MessageReactionRemoveAllEvt - -- ^ Fired when all reactions are removed from a cached message, use - -- 'RawMessageReactionRemoveEvt' to see reactions on uncached messages. - -- - -- The message passed will contain the removed events. - | RawMessageReactionRemoveAllEvt - -- ^ Fired when all reactions are removed from a message. - | TypingStartEvt - | UserUpdateEvt - | forall s a. CustomEvt s a - -- ^ A custom event, @s@ is the name and @a@ is the data sent to the handler - -data GuildCreateStatus - = GuildCreateNew -- ^ The guild was just joined - | GuildCreateAvailable -- ^ The guild is becoming available - deriving ( Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric GuildCreateStatus - -data GuildDeleteStatus - = GuildDeleteUnavailable -- ^ The guild became unavailable - | GuildDeleteRemoved -- ^ The bot was removed from the guild - deriving ( Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric GuildDeleteStatus - --- | A type family to decide what the parameters for an event handler should be --- determined by the type of event it is handling. -type family EHType (d :: EventType) where - EHType 'ReadyEvt = ReadyData - EHType 'ChannelCreateEvt = Channel - EHType 'ChannelUpdateEvt = (Channel, Channel) - EHType 'ChannelDeleteEvt = Channel - EHType 'ChannelpinsUpdateEvt = (Channel, Maybe UTCTime) - EHType 'GuildCreateEvt = (Guild, GuildCreateStatus) - EHType 'GuildUpdateEvt = (Guild, Guild) - EHType 'GuildDeleteEvt = (Guild, GuildDeleteStatus) - EHType 'GuildBanAddEvt = (Guild, User) - EHType 'GuildBanRemoveEvt = (Guild, User) - EHType 'GuildEmojisUpdateEvt = (Guild, [Emoji]) - EHType 'GuildIntegrationsUpdateEvt = Guild - EHType 'GuildMemberAddEvt = Member - EHType 'GuildMemberRemoveEvt = Member - EHType 'GuildMemberUpdateEvt = (Member, Member) - EHType 'GuildMembersChunkEvt = (Guild, [Member]) - EHType 'GuildRoleCreateEvt = (Guild, Role) - EHType 'GuildRoleUpdateEvt = (Guild, Role, Role) - EHType 'GuildRoleDeleteEvt = (Guild, Role) - EHType 'InviteCreateEvt = InviteCreateData - EHType 'InviteDeleteEvt = InviteDeleteData - EHType 'MessageCreateEvt = Message - EHType 'MessageUpdateEvt = (Message, Message) - EHType 'MessageDeleteEvt = Message - EHType 'MessageDeleteBulkEvt = [Message] - EHType 'MessageReactionAddEvt = (Message, Reaction) - EHType 'MessageReactionRemoveEvt = (Message, Reaction) - EHType 'MessageReactionRemoveAllEvt = Message - EHType 'RawMessageUpdateEvt = UpdatedMessage - EHType 'RawMessageDeleteEvt = Snowflake Message - EHType 'RawMessageDeleteBulkEvt = [Snowflake Message] - EHType 'RawMessageReactionAddEvt = Reaction - EHType 'RawMessageReactionRemoveEvt = Reaction - EHType 'RawMessageReactionRemoveAllEvt = Snowflake Message - EHType 'TypingStartEvt = (Channel, Snowflake User, UnixTimestamp) - EHType 'UserUpdateEvt = (User, User) - EHType ('CustomEvt s a) = a - -type StoredEHType t = EHType t -> IO () - -newtype EventHandlers = EventHandlers (TypeRepMap EventHandler) - -data EventHandlerWithID a = EventHandlerWithID - { ehID :: Integer - , eh :: a - } - -type family EHStorageType (t :: EventType) where - EHStorageType ('CustomEvt s a) = LH.HashMap TypeRep (LH.HashMap TypeRep [EventHandlerWithID (StoredEHType ('CustomEvt s a))]) - EHStorageType t = [EventHandlerWithID (StoredEHType t)] - -newtype EventHandler (t :: EventType) = EH - { unwrapEventHandler :: (Semigroup (EHStorageType t), Monoid (EHStorageType t)) => EHStorageType t - } - -instance Semigroup (EventHandler t) where - EH a <> EH b = EH $ a <> b - -instance Monoid (EventHandler t) where - mempty = EH mempty - -instance Default EventHandlers where - def = EventHandlers $ fromList [ WrapTypeable $ EH @'ReadyEvt [] - , WrapTypeable $ EH @'ChannelCreateEvt [] - , WrapTypeable $ EH @'ChannelUpdateEvt [] - , WrapTypeable $ EH @'ChannelDeleteEvt [] - , WrapTypeable $ EH @'ChannelpinsUpdateEvt [] - , WrapTypeable $ EH @'GuildCreateEvt [] - , WrapTypeable $ EH @'GuildUpdateEvt [] - , WrapTypeable $ EH @'GuildDeleteEvt [] - , WrapTypeable $ EH @'GuildBanAddEvt [] - , WrapTypeable $ EH @'GuildBanRemoveEvt [] - , WrapTypeable $ EH @'GuildEmojisUpdateEvt [] - , WrapTypeable $ EH @'GuildIntegrationsUpdateEvt [] - , WrapTypeable $ EH @'GuildMemberAddEvt [] - , WrapTypeable $ EH @'GuildMemberRemoveEvt [] - , WrapTypeable $ EH @'GuildMemberUpdateEvt [] - , WrapTypeable $ EH @'GuildMembersChunkEvt [] - , WrapTypeable $ EH @'GuildRoleCreateEvt [] - , WrapTypeable $ EH @'GuildRoleUpdateEvt [] - , WrapTypeable $ EH @'GuildRoleDeleteEvt [] - , WrapTypeable $ EH @'MessageCreateEvt [] - , WrapTypeable $ EH @'MessageUpdateEvt [] - , WrapTypeable $ EH @'MessageDeleteEvt [] - , WrapTypeable $ EH @'MessageDeleteBulkEvt [] - , WrapTypeable $ EH @'MessageReactionAddEvt [] - , WrapTypeable $ EH @'MessageReactionRemoveEvt [] - , WrapTypeable $ EH @'MessageReactionRemoveAllEvt [] - , WrapTypeable $ EH @'TypingStartEvt [] - , WrapTypeable $ EH @'UserUpdateEvt [] - , WrapTypeable $ EH @('CustomEvt Void Dynamic) LH.empty - ] - -instance Semigroup EventHandlers where - (EventHandlers a) <> (EventHandlers b) = EventHandlers $ TM.unionWith (<>) a b - -instance Monoid EventHandlers where - mempty = def - --- not sure what to think of this - -type family EHInstanceSelector (d :: EventType) :: Bool where - EHInstanceSelector ('CustomEvt _ _) = 'True - EHInstanceSelector _ = 'False - - -fromDynamicJust :: forall a. Typeable a => Dynamic -> a -fromDynamicJust d = case fromDynamic d of - Just x -> x - Nothing -> error $ "Extracting dynamic failed, wanted: " <> (show . typeRep $ Proxy @a) <> ", got: " <> (show $ dynTypeRep d) - - --- | A helper typeclass that is used to decide how to register regular --- events, and custom events which require storing in a map at runtime. -class InsertEventHandler a where - makeEventHandlers :: Proxy a -> Integer -> StoredEHType a -> EventHandlers - -instance (EHInstanceSelector a ~ flag, InsertEventHandler' flag a) => InsertEventHandler a where - makeEventHandlers = makeEventHandlers' (Proxy @flag) - -class InsertEventHandler' (flag :: Bool) a where - makeEventHandlers' :: Proxy flag -> Proxy a -> Integer -> StoredEHType a -> EventHandlers - -intoDynFn :: forall a. Typeable a => (a -> IO ()) -> (Dynamic -> IO ()) -intoDynFn fn = \d -> fn $ fromDynamicJust d - -instance (Typeable a, Typeable s, Typeable (StoredEHType ('CustomEvt s a)), (EHType ('CustomEvt s a) -> IO ()) ~ (a -> IO ())) - => InsertEventHandler' 'True ('CustomEvt s a) where - makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @('CustomEvt Void Dynamic) - (LH.singleton (typeRep $ Proxy @s) (LH.singleton (typeRep $ Proxy @a) [EventHandlerWithID id' (intoDynFn handler)])) - -instance (Typeable s, EHStorageType s ~ [EventHandlerWithID (StoredEHType s)], Typeable (StoredEHType s)) => InsertEventHandler' 'False s where - makeEventHandlers' _ _ id' handler = EventHandlers . TM.one $ EH @s [EventHandlerWithID id' handler] - - -class GetEventHandlers a where - getEventHandlers :: EventHandlers -> [StoredEHType a] - -instance (EHInstanceSelector a ~ flag, GetEventHandlers' flag a) => GetEventHandlers a where - getEventHandlers = getEventHandlers' (Proxy @a) (Proxy @flag) - -class GetEventHandlers' (flag :: Bool) a where - getEventHandlers' :: Proxy a -> Proxy flag -> EventHandlers -> [StoredEHType a] - -instance GetEventHandlers' 'True ('CustomEvt s a) where - getEventHandlers' _ _ _ = error "use getCustomEventHandlers instead" - -instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where - getEventHandlers' _ _ (EventHandlers handlers) = - let theseHandlers = unwrapEventHandler @s $ fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler s)) - in map eh theseHandlers - - -class RemoveEventHandler a where - removeEventHandler :: Proxy a -> Integer -> EventHandlers -> EventHandlers - -instance (EHInstanceSelector a ~ flag, RemoveEventHandler' flag a) => RemoveEventHandler a where - removeEventHandler = removeEventHandler' (Proxy @flag) - -class RemoveEventHandler' (flag :: Bool) a where - removeEventHandler' :: Proxy flag -> Proxy a -> Integer -> EventHandlers -> EventHandlers - -instance (Typeable s, Typeable a) => RemoveEventHandler' 'True ('CustomEvt s a) where - removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @('CustomEvt Void Dynamic) - (\(EH ehs) -> EH (LH.update (Just . LH.update (Just . filter ((/= id') . ehID)) (typeRep $ Proxy @a)) - (typeRep $ Proxy @s) ehs)) handlers - -instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) - => RemoveEventHandler' 'False s where - removeEventHandler' _ _ id' (EventHandlers handlers) = EventHandlers $ TM.adjust @s - (\(EH ehs) -> EH $ filter ((/= id') . ehID) ehs) handlers - - -getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic -> IO ()] -getCustomEventHandlers s a (EventHandlers handlers) = - let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromMaybe mempty - (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic))) - in map eh . concat $ LH.lookup s handlerMap >>= LH.lookup a diff --git a/src/Calamity/Commands.hs b/src/Calamity/Commands.hs deleted file mode 100644 --- a/src/Calamity/Commands.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | Calamity commands --- This module exports the DSL and core types for using commands -module Calamity.Commands - ( module Calamity.Commands.Dsl - , module Calamity.Commands.Error - , module Calamity.Commands.Handler - , module Calamity.Commands.Utils - , module Calamity.Commands.ParsePrefix - , module Calamity.Commands.Parser - , module Calamity.Commands.Help - , module Calamity.Commands.Context - -- * Commands - -- $commandDocs - ) where - -import Calamity.Commands.Dsl -import Calamity.Commands.Error -import Calamity.Commands.Handler -import Calamity.Commands.Help -import Calamity.Commands.ParsePrefix -import Calamity.Commands.Parser -import Calamity.Commands.Utils -import Calamity.Commands.Context ( Context ) - --- $commandDocs --- --- This module provides abstractions for writing declarative commands, that --- support grouping, pre-invokation checks, and automatic argument parsing by --- using a type level list of parameter types. --- --- A DSL is provided in "Calamity.Commands.Dsl" for constructing commands --- declaratively. --- --- You can implement 'Parser' for your own types to allow them to be used in the --- parameter list of commands. --- --- A default help command is provided in "Calamity.Commands.Help" which can be --- added just by using 'helpCommand' inside the command declaration DSL. --- --- --- ==== Custom Events --- --- The event handler registered by 'addCommands' will fire the following custom events: --- --- 1. @"command-error" ('Context', 'CommandError')@ --- --- Fired when a command returns an error. --- --- 2. @"command-not-found" ('Calamity.Types.Model.Channel.Message', ['Data.Text.Lazy.Text'])@ --- --- Fired when a valid prefix is used, but the command is not found. --- --- 3. @"command-invoked" 'Context'@ --- --- Fired when a command is successfully invoked. --- --- ==== Registered Metrics --- --- 1. Counter: @"commands_invoked" [name]@ --- --- Incremented on each command invokation, the parameter @name@ is the --- path/name of the invoked command. --- --- --- ==== Examples --- --- An example of using commands: --- --- @ --- 'addCommands' $ do --- 'helpCommand' --- 'command' \@\'['Calamity.Types.Model.User.User'] "utest" $ \\ctx u \-\> do --- 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx $ "got user: " '<>' 'TextShow.showtl' u --- 'group' "admin" $ do --- 'command' \@'[] "bye" $ \\ctx -> do --- 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx "bye!" --- 'Calamity.Client.stopBot' --- @ diff --git a/src/Calamity/Commands/AliasType.hs b/src/Calamity/Commands/AliasType.hs deleted file mode 100644 --- a/src/Calamity/Commands/AliasType.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | Named boolean for determining if something is an alias or not -module Calamity.Commands.AliasType - ( AliasType (..), - ) -where - -import GHC.Generics (Generic) -import TextShow (TextShow) -import qualified TextShow.Generic as TSG - -data AliasType - = Alias - | Original - deriving (Eq, Enum, Show, Generic) - deriving (TextShow) via TSG.FromGeneric AliasType diff --git a/src/Calamity/Commands/Check.hs b/src/Calamity/Commands/Check.hs deleted file mode 100644 --- a/src/Calamity/Commands/Check.hs +++ /dev/null @@ -1,51 +0,0 @@ --- | Command invokation preconditions -module Calamity.Commands.Check - ( Check(..) - , buildCheck - , buildCheckPure - , runCheck ) where - -import {-# SOURCE #-} Calamity.Commands.Context -import Calamity.Commands.Error -import Calamity.Internal.RunIntoIO -import Calamity.Internal.Utils - -import Control.Lens hiding ( (<.>), Context ) - -import Data.Generics.Labels () -import Data.Maybe -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import GHC.Generics - -import qualified Polysemy as P - --- | A check for a command. --- --- Every check for a command must return Nothing for the command to be run. -data Check = MkCheck - { name :: S.Text - -- ^ The name of the check. - , callback :: Context -> IO (Maybe L.Text) - -- ^ The callback for the check, returns Nothing if it passes, otherwise - -- returns the reason for it not passing. - } - deriving ( Generic ) - --- | Given the name of a check and a callback in the 'P.Sem' monad, build a --- check by transforming the Polysemy action into an IO action. -buildCheck :: P.Member (P.Final IO) r => S.Text -> (Context -> P.Sem r (Maybe L.Text)) -> P.Sem r Check -buildCheck name cb = do - cb' <- bindSemToIO cb - let cb'' = fromMaybe (Just "failed internally") <.> cb' - pure $ MkCheck name cb'' - --- | Given the name of a check and a pure callback function, build a check. -buildCheckPure :: S.Text -> (Context -> Maybe L.Text) -> Check -buildCheckPure name cb = MkCheck name (pure . cb) - --- | Given an invokation 'Context', run a check and transform the result into an --- @'Either' 'CommandError' ()@. -runCheck :: P.Member (P.Embed IO) r => Context -> Check -> P.Sem r (Either CommandError ()) -runCheck ctx chk = P.embed (callback chk ctx) <&> justToEither . (CheckError (chk ^. #name) <$>) diff --git a/src/Calamity/Commands/Command.hs b/src/Calamity/Commands/Command.hs deleted file mode 100644 --- a/src/Calamity/Commands/Command.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | Commands and stuff -module Calamity.Commands.Command - ( Command(..) ) where - -import Calamity.Commands.Check -import Calamity.Commands.Context -import Calamity.Commands.Error -import Calamity.Commands.Group - -import Control.Lens hiding ( (<.>), Context ) - -import Data.List.NonEmpty ( NonEmpty ) -import Data.Text as S -import Data.Text.Lazy as L - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG -import qualified Data.List.NonEmpty as NE - --- | A command -data Command = forall a. Command - { names :: NonEmpty S.Text - , parent :: Maybe Group - , hidden :: Bool - -- ^ If this command is hidden - , checks :: [Check] - -- ^ A list of checks that must pass for this command to be invoked - , params :: [S.Text] - -- ^ A list of the parameters the command takes, only used for constructing - -- help messages. - , help :: Context -> L.Text - -- ^ A function producing the \'help\' for the command. - , parser :: Context -> IO (Either CommandError a) - -- ^ A function that parses the context for the command, producing the input - -- @a@ for the command. - , callback :: (Context, a) -> IO (Maybe L.Text) - -- ^ A function that given the context and the input (@a@) of the command, - -- performs the action of the command. - } - -data CommandS = CommandS - { names :: NonEmpty S.Text - , params :: [S.Text] - , parent :: Maybe S.Text - , checks :: [S.Text] - , hidden :: Bool - } - deriving ( Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric CommandS - -instance Show Command where - showsPrec d Command {names, params, parent, checks, hidden} = - showsPrec d $ - CommandS - names - params - (NE.head <$> parent ^? _Just . #names) - (checks ^.. traverse . #name) - hidden - -instance TextShow Command where - showbPrec d Command {names, params, parent, checks, hidden} = - showbPrec d $ - CommandS - names - params - (NE.head <$> parent ^? _Just . #names) - (checks ^.. traverse . #name) - hidden diff --git a/src/Calamity/Commands/Command.hs-boot b/src/Calamity/Commands/Command.hs-boot deleted file mode 100644 --- a/src/Calamity/Commands/Command.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ --- | Commands and stuff -module Calamity.Commands.Command - ( Command - ) where - -import TextShow - -data Command - -instance Show Command -instance TextShow Command diff --git a/src/Calamity/Commands/CommandUtils.hs b/src/Calamity/Commands/CommandUtils.hs deleted file mode 100644 --- a/src/Calamity/Commands/CommandUtils.hs +++ /dev/null @@ -1,212 +0,0 @@ --- | Command utilities -module Calamity.Commands.CommandUtils - ( TypedCommandC - , CommandForParsers - , buildCommand - , buildCommand' - , buildParser - , buildCallback - , runCommand - , invokeCommand - , groupPath - , commandPath - , commandParams ) where - -import Calamity.Commands.Check -import Calamity.Commands.Command -import Calamity.Commands.Context -import Calamity.Commands.Error -import Calamity.Commands.Group -import Calamity.Commands.Parser -import Calamity.Internal.RunIntoIO -import Calamity.Internal.Utils - -import Control.Lens hiding ( (<.>), Context ) -import Control.Monad - -import Data.Foldable -import Data.Kind -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import Data.Maybe -import Data.Text as S -import Data.Text.Lazy as L - -import qualified Polysemy as P -import qualified Polysemy.Error as P -import qualified Polysemy.Fail as P - -groupPath :: Group -> [S.Text] -groupPath Group { names, parent } = maybe [] groupPath parent ++ [NE.head names] - -commandPath :: Command -> [S.Text] -commandPath Command { names, parent } = maybe [] groupPath parent ++ [NE.head names] - --- | Format a command's parameters -commandParams :: Command -> L.Text -commandParams Command { params } = L.fromStrict $ S.intercalate ", " params - --- | Given the properties of a 'Command' with the @parser@ and @callback@ in the --- 'P.Sem' monad, build a command by transforming the Polysemy actions into IO --- actions. -buildCommand' :: P.Member (P.Final IO) r - => NonEmpty S.Text - -- ^ The name (and aliases) of the command - -> Maybe Group - -- ^ The parent group of the command - -> Bool - -- ^ If the command is hidden - -> [Check] - -- ^ The checks for the command - -> [S.Text] - -- ^ The names of the command's parameters - -> (Context -> L.Text) - -- ^ The help generator for this command - -> (Context -> P.Sem r (Either CommandError a)) - -- ^ The parser for this command - -> ((Context, a) -> P.Sem (P.Fail ': r) ()) - -- ^ The callback for this command - -> P.Sem r Command -buildCommand' names@(name :| _) parent hidden checks params help parser cb = do - cb' <- buildCallback cb - parser' <- buildParser name parser - pure $ Command names parent hidden checks params help parser' cb' - --- | Given the properties of a 'Command', a callback, and a type level list of --- the parameters, build a command by constructing a parser and wiring it up to --- the callback. --- --- ==== Examples --- --- Building a command that bans a user by id. --- --- @ --- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneStarConcat' 'S.Text')] --- "ban" 'Nothing' [] ('const' "Ban a user") $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of --- 'Just' guild -> do --- 'void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid --- 'void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) --- 'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds." --- @ -buildCommand :: forall ps r. - (P.Member (P.Final IO) r, TypedCommandC ps r) - => NonEmpty S.Text - -- ^ The name (and aliases) of the command - -> Maybe Group - -- ^ The parent group of the command - -> Bool - -- ^ If the command is hidden - -> [Check] - -- ^ The checks for the command - -> (Context -> L.Text) - -- ^ The help generator for this command - -> (Context -> CommandForParsers ps r) - -- ^ The callback foor this command - -> P.Sem r Command -buildCommand names parent hidden checks help command = - let (parser, cb) = buildTypedCommand @ps command - in buildCommand' names parent hidden checks (paramNames @ps @r) help parser cb - --- | Given the name of the command the parser is for and a parser function in --- the 'P.Sem' monad, build a parser by transforming the Polysemy action into an --- IO action. -buildParser :: P.Member (P.Final IO) r - => S.Text - -> (Context -> P.Sem r (Either CommandError a)) - -> P.Sem r (Context -> IO (Either CommandError a)) -buildParser name cb = do - cb' <- bindSemToIO cb - let cb'' ctx = fromMaybe (Left $ ParseError ("Parser for command: " <> name) "failed internally") <$> cb' ctx - pure cb'' - --- | Given a callback for a command in the 'P.Sem' monad, build a command callback by --- transforming the Polysemy action into an IO action. -buildCallback - :: P.Member (P.Final IO) r => ((Context, a) -> P.Sem (P.Fail ': r) ()) -> P.Sem r ((Context, a) -> IO (Maybe L.Text)) -buildCallback cb = do - cb' <- bindSemToIO (\x -> P.runFail (cb x) <&> \case - Left e -> Just $ L.pack e - Right _ -> Nothing) - let cb'' = fromMaybe (Just "failed internally") <.> cb' - pure cb'' - --- | Given an invokation 'Context', run a command. This does not perform the command's checks. -runCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ()) -runCommand ctx Command { names = name :| _, parser, callback } = P.embed (parser ctx) >>= \case - Left e -> pure $ Left e - Right p' -> P.embed (callback (ctx, p')) <&> justToEither . (InvokeError name <$>) - --- | Given an invokation 'Context', first run all of the command's checks, then --- run the command if they all pass. -invokeCommand :: P.Member (P.Embed IO) r => Context -> Command -> P.Sem r (Either CommandError ()) -invokeCommand ctx cmd@Command { checks } = P.runError $ do - for_ checks (P.fromEither <=< runCheck ctx) - P.fromEither =<< runCommand ctx cmd - -type CommandSemType r = P.Sem (P.Fail ': r) () - --- | Some constraints used for making parameter typed commands work -type TypedCommandC ps r = - ( ApplyTupRes (ParserResult (ListToTup ps)) (CommandSemType r) ~ CommandForParsers ps r - , Parser (ListToTup ps) r - , ApplyTup (ParserResult (ListToTup ps)) (CommandSemType r) - , ParamNamesForParsers ps r - ) - -buildTypedCommand - :: forall (ps :: [Type]) a r. - (TypedCommandC ps r, a ~ ParserResult (ListToTup ps)) - => (Context -> CommandForParsers ps r) - -> ( Context - -> P.Sem r (Either CommandError a) - , (Context, a) - -> P.Sem (P.Fail ': r) ()) -buildTypedCommand cmd = let parser ctx = buildTypedCommandParser @ps ctx (ctx ^. #unparsedParams) - consumer (ctx, r) = applyTup (cmd ctx) r - in (parser, consumer) - -class ParamNamesForParsers (ps :: [Type]) r where - paramNames :: [S.Text] - -instance ParamNamesForParsers '[] r where - paramNames = [] - -instance (Parser x r, ParamNamesForParsers xs r) => ParamNamesForParsers (x : xs) r where - paramNames = (parserName @x @r : paramNames @xs @r) - -class ApplyTup a b where - type ApplyTupRes a b - - applyTup :: ApplyTupRes a b -> a -> b - -instance ApplyTup as b => ApplyTup (a, as) b where - type ApplyTupRes (a, as) b = a -> ApplyTupRes as b - - applyTup f (a, as) = applyTup (f a) as - -instance ApplyTup () b where - type ApplyTupRes () b = b - - applyTup r () = r - -buildTypedCommandParser :: forall (ps :: [Type]) r. Parser (ListToTup ps) r => Context -> L.Text -> P.Sem r (Either CommandError (ParserResult (ListToTup ps))) -buildTypedCommandParser ctx t = (runCommandParser ctx t $ parse @(ListToTup ps) @r) <&> \case - Right r -> Right r - Left (n, e) -> Left $ ParseError n e - -type family ListToTup (ps :: [Type]) where - ListToTup '[] = () - ListToTup (x ': xs) = (x, ListToTup xs) - --- | Transform a type level list of types implementing the 'Parser' typeclass into --- the type a command callback matching those parameters should be. --- --- As an example: --- --- @ --- 'CommandForParsers' [ 'L.Text', 'Calamity.Types.Snowflake' 'Calamity.Types.User', 'Calamity.Commands.Parser.Named' "something" 'L.Text' ] r ~ --- ('L.Text' -> 'Calamity.Types.Snowflake' 'Calamity.Types.User' -> 'L.Text' -> 'P.Sem' r ('P.Fail' ': r) ()) --- @ -type family CommandForParsers (ps :: [Type]) r where - CommandForParsers '[] r = P.Sem (P.Fail ': r) () - CommandForParsers (x ': xs) r = ParserResult x -> CommandForParsers xs r diff --git a/src/Calamity/Commands/Context.hs b/src/Calamity/Commands/Context.hs deleted file mode 100644 --- a/src/Calamity/Commands/Context.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | Command invokation context -module Calamity.Commands.Context - ( Context(..) ) where - -import {-# SOURCE #-} Calamity.Commands.Command -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake -import Calamity.Types.Tellable - -import qualified Data.Text.Lazy as L - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - --- | Invokation context for commands -data Context = Context - { 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 - , channel :: Channel - -- ^ The channel the command was invoked from - , user :: User - -- ^ The user that invoked the command - , command :: Command - -- ^ The command that was invoked - , prefix :: L.Text - -- ^ The prefix that was used to invoke the command - , unparsedParams :: L.Text - -- ^ The message remaining after consuming the prefix - } - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Context - -instance Tellable Context where - getChannel Context { channel } = pure . getID $ channel diff --git a/src/Calamity/Commands/Context.hs-boot b/src/Calamity/Commands/Context.hs-boot deleted file mode 100644 --- a/src/Calamity/Commands/Context.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ --- | Command invokation context -module Calamity.Commands.Context - ( Context ) where - -import TextShow - -data Context - -instance Show Context -instance TextShow Context diff --git a/src/Calamity/Commands/Dsl.hs b/src/Calamity/Commands/Dsl.hs deleted file mode 100644 --- a/src/Calamity/Commands/Dsl.hs +++ /dev/null @@ -1,361 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} - --- | A DSL for generating commands and groups -module Calamity.Commands.Dsl - ( -- * Commands DSL - -- $dslTutorial - command - , command' - , commandA - , commandA' - , hide - , help - , requires - , requires' - , requiresPure - , group - , group' - , groupA - , groupA' - , DSLState - , raiseDSL - , fetchHandler ) where - -import Calamity.Commands.AliasType -import Calamity.Commands.Check -import Calamity.Commands.Command hiding ( help ) -import Calamity.Commands.CommandUtils -import Calamity.Commands.Context hiding ( command ) -import Calamity.Commands.Error -import Calamity.Commands.Group hiding ( help ) -import Calamity.Commands.Handler -import Calamity.Internal.LocalWriter - -import qualified Data.HashMap.Lazy as LH -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified Polysemy.Tagged as P -import qualified Polysemy.Fixpoint as P -import qualified Polysemy.Reader as P -import Data.List.NonEmpty (NonEmpty(..)) - --- $dslTutorial --- --- This module provides a way of constructing bot commands in a declarative way. --- --- The main component of this is the 'command' function, which takes a --- type-level list of command parameters, the name, and the callback and --- produces a command. There are also the alternatives 'command'', 'commandA' --- and 'commandA'', for when you want to handle parsing of the input yourself, --- and/or want aliases of the command. --- --- The functions: 'hide', 'help', 'requires', and 'group' can be used to change --- attributes of any commands declared inside the monadic action passed to them, --- for example: --- --- @ --- 'hide' '$' do --- 'command' \@'[] "test" \ctx -> 'pure' () --- @ --- --- In the above block, any command declared inside 'hide' will have it's --- \'hidden\' flag set and will not be shown by the default help command: --- 'Calamity.Commands.Help.helpCommand' --- --- The 'Calamity.Commands.Help.helpCommand' function can be used to create a --- help command for the commands DSL action it is used in, read it's doc page --- for more information on how it functions. --- --- The 'Calamity.Commands.Utils.addCommands' function creates the command --- handler for the commands registered in the passed action, it is what reads a --- message to determine what command was invoked. It should be used to register the --- commands with the bot by using it inside the setup action, for example: --- --- @ --- 'Calamity.Client.runBotIO' ('Calamity.BotToken' token) --- $ 'Calamity.Commands.Utils.addCommands' $ do --- 'Calamity.Commands.Help.helpCommand' --- 'Calamity.Commands.Dsl.command' \@'[] "test" \ctx -> --- 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' \@'L.Text' ctx "hi" --- @ --- --- The above block will create a command with no parameters named \'test\', --- along with a help command. - -type DSLState r = - ( LocalWriter (LH.HashMap S.Text (Command, AliasType)) - ': LocalWriter (LH.HashMap S.Text (Group, AliasType)) - ': P.Reader (Maybe Group) - ': P.Tagged "hidden" (P.Reader Bool) - ': P.Reader (Context -> L.Text) - ': P.Tagged "original-help" (P.Reader (Context -> L.Text)) - ': P.Reader [Check] - ': P.Reader CommandHandler - ': P.Fixpoint - ': r - ) - -raiseDSL :: P.Sem r a -> P.Sem (DSLState r) a -raiseDSL = P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise . P.raise - --- | Given the command name and parameter names, @parser@ and @callback@ for a --- command in the 'P.Sem' monad, build a command by transforming the Polysemy --- actions into IO actions. Then register the command. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. -command' - :: P.Member (P.Final IO) r - => S.Text - -- ^ The name of the command - -> [S.Text] - -- ^ The names of the command's parameters - -> (Context -> P.Sem r (Either CommandError a)) - -- ^ The parser for this command - -> ((Context, a) -> P.Sem (P.Fail ': r) ()) - -- ^ The callback for this command - -> P.Sem (DSLState r) Command -command' name params parser cb = commandA' name [] params parser cb - --- | Given the command name, aliases, and parameter names, @parser@ and --- @callback@ for a command in the 'P.Sem' monad, build a command by --- transforming the Polysemy actions into IO actions. Then register the command. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. -commandA' - :: P.Member (P.Final IO) r - => S.Text - -- ^ The name of the command - -> [S.Text] - -- ^ The aliases for the command - -> [S.Text] - -- ^ The names of the command's parameters - -> (Context -> P.Sem r (Either CommandError a)) - -- ^ The parser for this command - -> ((Context, a) -> P.Sem (P.Fail ': r) ()) - -- ^ The callback for this command - -> P.Sem (DSLState r) Command -commandA' name aliases params parser cb = do - parent <- P.ask @(Maybe Group) - hidden <- P.tag $ P.ask @Bool - checks <- P.ask @[Check] - help' <- P.ask @(Context -> L.Text) - cmd <- raiseDSL $ buildCommand' (name :| aliases) parent hidden checks params help' parser cb - ltell $ LH.singleton name (cmd, Original) - ltell $ LH.fromList [(name, (cmd, Alias)) | name <- aliases] - pure cmd - --- | Given the name of a command and a callback, and a type level list of --- the parameters, build and register a command. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. --- --- Command parameters are parsed by first invoking --- 'Calamity.Commands.Parser.parse' for the first --- 'Calamity.Commands.Parser.Parser', then running the next parser on the --- remaining input, and so on. --- --- ==== Examples --- --- Building a command that bans a user by id. --- --- @ --- 'command' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), --- 'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneStarConcat' 'S.Text')] --- "ban" $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of --- 'Just' guild -> do --- 'Control.Monad.void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid --- 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) --- 'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds." --- @ -command :: forall ps r. - ( P.Member (P.Final IO) r, - TypedCommandC ps r) - => S.Text - -- ^ The name of the command - -> (Context -> CommandForParsers ps r) - -- ^ The callback for this command - -> P.Sem (DSLState r) Command -command name cmd = commandA @ps name [] cmd - --- | Given the name and aliases of a command and a callback, and a type level list of --- the parameters, build and register a command. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. --- --- ==== Examples --- --- Building a command that bans a user by id. --- --- @ --- 'commandA' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), --- 'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneStarConcat' 'S.Text')] --- "ban" [] $ \\ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of --- 'Just' guild -> do --- 'Control.Monad.void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid --- 'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx ("Banned user `" '<>' 'TextShow.showt' uid '<>' "` with reason: " '<>' r) --- 'Nothing' -> 'void' $ 'Calamity.Types.Tellable.tell' @'L.Text' ctx "Can only ban users from guilds." --- @ -commandA :: forall ps r. - ( P.Member (P.Final IO) r, - TypedCommandC ps r) - => S.Text - -- ^ The name of the command - -> [S.Text] - -- ^ The aliases for the command - -> (Context -> CommandForParsers ps r) - -- ^ The callback for this command - -> P.Sem (DSLState r) Command -commandA name aliases cmd = do - parent <- P.ask @(Maybe Group) - hidden <- P.tag $ P.ask @Bool - checks <- P.ask @[Check] - help' <- P.ask @(Context -> L.Text) - cmd' <- raiseDSL $ buildCommand @ps (name :| aliases) parent hidden checks help' cmd - ltell $ LH.singleton name (cmd', Original) - ltell $ LH.fromList [(name, (cmd', Alias)) | name <- aliases] - pure cmd' - --- | Set the visibility of any groups or commands registered inside the given --- action to hidden. -hide :: P.Member (P.Tagged "hidden" (P.Reader Bool)) r - => P.Sem r a - -> P.Sem r a -hide = P.tag @"hidden" . P.local @Bool (const True) . P.raise - --- | Set the help for any groups or commands registered inside the given action. -help :: P.Member (P.Reader (Context -> L.Text)) r - => (Context -> L.Text) - -> P.Sem r a - -> P.Sem r a -help = P.local . const - --- | Add to the list of checks for any commands registered inside the given --- action. -requires :: [Check] - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -requires = P.local . (<>) - --- | Construct a check and add it to the list of checks for any commands --- registered inside the given action. --- --- Refer to 'Calamity.Commands.Check.Check' for more info on checks. -requires' :: P.Member (P.Final IO) r - => S.Text - -- ^ The name of the check - -> (Context -> P.Sem r (Maybe L.Text)) - -- ^ The callback for the check - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -requires' name cb m = do - check <- raiseDSL $ buildCheck name cb - requires [check] m - --- | Construct some pure checks and add them to the list of checks for any --- commands registered inside the given action. --- --- Refer to 'Calamity.Commands.Check.Check' for more info on checks. -requiresPure :: [(S.Text, Context -> Maybe L.Text)] - -- A list of check names and check callbacks - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -requiresPure checks = requires $ map (uncurry buildCheckPure) checks - --- | Construct a group and place any commands registered in the given action --- into the new group. --- --- This also resets the @help@ function back to it's original value, use --- 'group'' if you don't want that (i.e. your help function is context aware). -group :: P.Member (P.Final IO) r - => S.Text - -- ^ The name of the group - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -group name m = groupA name [] m - --- | Construct a group with aliases and place any commands registered in the --- given action into the new group. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. --- --- This also resets the @help@ function back to it's original value, use --- 'group'' if you don't want that (i.e. your help function is context aware). -groupA :: P.Member (P.Final IO) r - => S.Text - -- ^ The name of the group - -> [S.Text] - -- ^ The aliases of the group - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -groupA name aliases m = mdo - parent <- P.ask @(Maybe Group) - hidden <- P.tag $ P.ask @Bool - checks <- P.ask @[Check] - help' <- P.ask @(Context -> L.Text) - origHelp <- fetchOrigHelp - let group' = Group (name :| aliases) parent hidden commands children help' checks - (children, (commands, res)) <- llisten @(LH.HashMap S.Text (Group, AliasType)) $ - llisten @(LH.HashMap S.Text (Command, AliasType)) $ - P.local @(Maybe Group) (const $ Just group') $ - P.local @(Context -> L.Text) (const origHelp) m - ltell $ LH.singleton name (group', Original) - ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases] - pure res - -fetchOrigHelp :: P.Member (P.Tagged "original-help" (P.Reader (Context -> L.Text))) r => P.Sem r (Context -> L.Text) -fetchOrigHelp = P.tag P.ask - --- | Construct a group and place any commands registered in the given action --- into the new group. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. --- --- Unlike 'help' this doesn't reset the @help@ function back to it's original --- value. -group' :: P.Member (P.Final IO) r - => S.Text - -- The name of the group - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -group' name m = groupA' name [] m - --- | Construct a group with aliases and place any commands registered in the given action --- into the new group. --- --- The parent group, visibility, checks, and command help are drawn from the --- reader context. --- --- Unlike 'help' this doesn't reset the @help@ function back to it's original --- value. -groupA' :: P.Member (P.Final IO) r - => S.Text - -- ^ The name of the group - -> [S.Text] - -- ^ The aliases of the group - -> P.Sem (DSLState r) a - -> P.Sem (DSLState r) a -groupA' name aliases m = mdo - parent <- P.ask @(Maybe Group) - hidden <- P.tag $ P.ask @Bool - checks <- P.ask @[Check] - help' <- P.ask @(Context -> L.Text) - let group' = Group (name :| aliases) parent hidden commands children help' checks - (children, (commands, res)) <- llisten @(LH.HashMap S.Text (Group, AliasType)) $ - llisten @(LH.HashMap S.Text (Command, AliasType)) $ - P.local @(Maybe Group) (const $ Just group') m - ltell $ LH.singleton name (group', Original) - ltell $ LH.fromList [(name, (group', Alias)) | name <- aliases] - pure res - --- | Retrieve the final command handler for this block -fetchHandler :: P.Sem (DSLState r) CommandHandler -fetchHandler = P.ask diff --git a/src/Calamity/Commands/Error.hs b/src/Calamity/Commands/Error.hs deleted file mode 100644 --- a/src/Calamity/Commands/Error.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Command errors -module Calamity.Commands.Error - ( CommandError(..) ) where - -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data CommandError - = ParseError S.Text -- ^ The type of the parser - L.Text -- ^ The reason that parsing failed - | CheckError S.Text -- ^ The name of the check that failed - L.Text -- ^ The reason for the check failing - | InvokeError S.Text -- ^ The name of the command that failed - L.Text -- ^ The reason for failing - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric CommandError diff --git a/src/Calamity/Commands/Group.hs b/src/Calamity/Commands/Group.hs deleted file mode 100644 --- a/src/Calamity/Commands/Group.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | Command groups -module Calamity.Commands.Group - ( Group(..) ) where - -import Calamity.Commands.AliasType -import Calamity.Commands.Check -import {-# SOURCE #-} Calamity.Commands.Command -import {-# SOURCE #-} Calamity.Commands.Context - -import Control.Lens hiding ( (<.>), Context ) - -import qualified Data.HashMap.Lazy as LH -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE - --- | A group of commands -data Group = Group - { names :: NonEmpty S.Text - , parent :: Maybe Group - , hidden :: Bool - , commands :: LH.HashMap S.Text (Command, AliasType) - -- ^ Any child commands of this group - , children :: LH.HashMap S.Text (Group, AliasType) - -- ^ Any child groups of this group - , help :: Context -> L.Text - -- ^ A function producing the \'help' for the group - , checks :: [Check] - -- ^ A list of checks that must pass - } - deriving ( Generic ) - -data GroupS = GroupS - { names :: NonEmpty S.Text - , parent :: Maybe S.Text - , commands :: LH.HashMap S.Text (Command, AliasType) - , children :: LH.HashMap S.Text (Group, AliasType) - , hidden :: Bool - } - deriving ( Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric GroupS - -instance Show Group where - showsPrec d Group {names, parent, commands, children, hidden} = showsPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children hidden - -instance TextShow Group where - showbPrec d Group {names, parent, commands, children, hidden} = showbPrec d $ GroupS names (NE.head <$> parent ^? _Just . #names) commands children hidden diff --git a/src/Calamity/Commands/Handler.hs b/src/Calamity/Commands/Handler.hs deleted file mode 100644 --- a/src/Calamity/Commands/Handler.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | A command handler -module Calamity.Commands.Handler - ( CommandHandler(..) ) where - -import Calamity.Commands.AliasType -import Calamity.Commands.Command -import Calamity.Commands.Group - -import qualified Data.HashMap.Lazy as LH -import qualified Data.Text as S - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data CommandHandler = CommandHandler - { groups :: LH.HashMap S.Text (Group, AliasType) - -- ^ Top level groups - , commands :: LH.HashMap S.Text (Command, AliasType) - -- ^ Top level commands - } - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric CommandHandler diff --git a/src/Calamity/Commands/Help.hs b/src/Calamity/Commands/Help.hs deleted file mode 100644 --- a/src/Calamity/Commands/Help.hs +++ /dev/null @@ -1,193 +0,0 @@ --- | A default help command implementation -module Calamity.Commands.Help - ( helpCommand' - , helpCommand ) where - -import Calamity.Client.Types -import Calamity.Commands.AliasType -import Calamity.Commands.Check -import Calamity.Commands.Command -import Calamity.Commands.CommandUtils -import Calamity.Commands.Context -import Calamity.Commands.Dsl -import Calamity.Commands.Group -import Calamity.Commands.Handler -import Calamity.Internal.LocalWriter -import Calamity.Types.Tellable - -import Control.Applicative -import Control.Lens hiding ( Context(..) ) -import Control.Monad - -import qualified Data.HashMap.Lazy as LH -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import Data.Maybe ( catMaybes ) -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified Polysemy.Reader as P -import Data.Maybe (mapMaybe) - -data CommandOrGroup - = Command' Command - | Group' Group [S.Text] - -helpCommandHelp :: Context -> L.Text -helpCommandHelp _ = "Show help for a command or group." - -helpForCommand :: Context -> Command -> L.Text -helpForCommand ctx (cmd@Command { names, checks, help }) = "```\nUsage: " <> prefix' <> path' <> " " <> params' <> "\n" <> - aliasesFmt <> - checksFmt <> - help ctx <> "\n```" - where prefix' = ctx ^. #prefix - path' = L.unwords . map L.fromStrict $ commandPath cmd - params' = commandParams cmd - aliases = map L.fromStrict $ NE.tail names - checks' = map L.fromStrict . map (^. #name) $ checks - aliasesFmt = if null aliases then "" else "Aliases: " <> L.unwords aliases <> "\n" - checksFmt = if null checks' then "" else "Checks: " <> L.unwords checks' <> "\n\n" - -fmtCommandWithParams :: Command -> L.Text -fmtCommandWithParams cmd@Command { names } = formatWithAliases names <> " " <> commandParams cmd - -formatWithAliases :: NonEmpty S.Text -> L.Text -formatWithAliases (name :| aliases) = L.fromStrict name <> aliasesFmt - where - aliasesFmt = case aliases of - [] -> "" - aliases' -> "[" <> L.intercalate "|" (map L.fromStrict aliases') <> "]" - -onlyOriginals :: [(a, AliasType)] -> [a] -onlyOriginals = mapMaybe inner - where inner (_, Alias) = Nothing - inner (a, Original) = Just a - -onlyVisibleC :: [Command] -> [Command] -onlyVisibleC = catMaybes . map notHiddenC - -onlyVisibleG :: [Group] -> [Group] -onlyVisibleG = catMaybes . map notHiddenG - -helpForGroup :: Context -> Group -> L.Text -helpForGroup ctx grp = "```\nGroup: " <> path' <> "\n" <> - aliasesFmt <> - checksFmt <> - (grp ^. #help) ctx <> "\n" <> - groupsMsg <> commandsMsg <> "\n```" - where path' = L.fromStrict . S.unwords $ groupPath grp - groups = onlyVisibleG . onlyOriginals . LH.elems $ grp ^. #children - commands = onlyVisibleC .onlyOriginals . LH.elems $ grp ^. #commands - groupsFmt = map formatWithAliases (groups ^.. traverse . #names) - groupsMsg = if null groups then "" else "The following child groups exist:\n" <> (L.unlines . map ("- " <>) $ groupsFmt) - commandsMsg = if null commands then "" else "\nThe following child commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands) - aliases = map L.fromStrict . NE.tail $ grp ^. #names - checks' = map L.fromStrict . map (^. #name) $ grp ^. #checks - aliasesFmt = if null aliases then "" else "Aliases: " <> L.unwords aliases <> "\n" - checksFmt = if null checks' then "" else "Checks: " <> L.unwords checks' <> "\n\n" - -rootHelp :: CommandHandler -> L.Text -rootHelp handler = "```\n" <> groupsMsg <> commandsMsg <> "\n```" - where groups = onlyVisibleG . onlyOriginals . LH.elems $ handler ^. #groups - commands = onlyVisibleC . onlyOriginals . LH.elems $ handler ^. #commands - groupsFmt = map formatWithAliases (groups ^.. traverse . #names) - groupsMsg = if null groups then "" else "The following groups exist:\n" <> (L.unlines . map ("- " <>) $ groupsFmt) - commandsMsg = if null commands then "" else "\nThe following commands exist:\n" <> (L.unlines . map ("- " <>) . map fmtCommandWithParams $ commands) - -helpCommandCallback :: BotC r => CommandHandler -> Context -> [S.Text] -> P.Sem (P.Fail ': r) () -helpCommandCallback handler ctx path = do - case findCommandOrGroup handler path of - Just (Command' cmd@Command { names }) -> - void $ tell @L.Text ctx $ "Help for command `" <> L.fromStrict (NE.head names) <> "`: \n" <> helpForCommand ctx cmd - Just (Group' grp@Group { names } remainingPath) -> - let failedMsg = if null remainingPath - then "" - else "No command or group with the path: `" <> L.fromStrict (S.unwords remainingPath) <> "` exists for the group: `" <> L.fromStrict (NE.head names) <> "`\n" - in void $ tell @L.Text ctx $ failedMsg <> "Help for group `" <> L.fromStrict (NE.head names) <> "`: \n" <> helpForGroup ctx grp - Nothing -> let failedMsg = if null path - then "" - else "No command or group with the path: `" <> L.fromStrict (S.unwords path) <> "` was found.\n" - in void $ tell @L.Text ctx $ failedMsg <> rootHelp handler - --- | 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 --- groups in the passed 'CommandHandler'. -helpCommand' :: BotC r => CommandHandler -> Maybe Group -> [Check] -> P.Sem r Command -helpCommand' handler parent checks = buildCommand @'[[S.Text]] ("help" :| []) parent False checks helpCommandHelp - (helpCommandCallback handler) - --- | Create and register the default help command for all the commands --- registered in the commands DSL this is used in. --- --- The registered command will have the name \'help\', called with no parameters --- it will print the top-level groups and commands, for example: --- --- @ --- The following groups exist: --- - reanimate --- - prefix[prefixes] --- - alias[aliases] --- - remind[reminder|reminders] --- --- The following commands exist: --- - help :[Text] --- @ --- --- Both commands and groups are listed in the form: @\[\|\]@, --- commands also have their parameter list shown. --- --- If a path to a group is passed, the help, aliases, and pre-invokation checks --- will be listed, along with the subgroups and commands, For example: --- --- @ --- Help for group remind: --- Group: remind --- Aliases: reminder reminders --- Commands related to making reminders --- --- The following child commands exist: --- - list --- - remove reminder_id:Text --- - add :KleenePlusConcat Text --- @ --- --- If a command path is passed, the usage, checks and help for the command are --- shown, for example: --- --- @ --- Help for command add: --- Usage: c!prefix add prefix:Text --- Checks: prefixLimit guildOnly --- --- Add a new prefix --- @ -helpCommand :: BotC r => P.Sem (DSLState r) Command -helpCommand = do - handler <- P.ask @CommandHandler - parent <- P.ask @(Maybe Group) - checks <- P.ask @[Check] - cmd <- raiseDSL $ helpCommand' handler parent checks - ltell $ LH.singleton "help" (cmd, Original) - pure cmd - -notHiddenC :: Command -> Maybe Command -notHiddenC c@(Command { hidden }) = if hidden then Nothing else Just c - -notHiddenG :: Group -> Maybe Group -notHiddenG g@(Group { hidden }) = if hidden then Nothing else Just g - -findCommandOrGroup :: CommandHandler -> [S.Text] -> Maybe CommandOrGroup -findCommandOrGroup handler path = go (handler ^. #commands, handler ^. #groups) path - where go :: (LH.HashMap S.Text (Command, AliasType), LH.HashMap S.Text (Group, AliasType)) - -> [S.Text] - -> Maybe CommandOrGroup - go (commands, groups) (x : xs) = - case LH.lookup x commands of - Just (notHiddenC -> Just cmd, _) -> Just (Command' cmd) - _ -> case LH.lookup x groups of - Just (notHiddenG -> Just group, _) -> go (group ^. #commands, group ^. #children) xs <|> Just (Group' group xs) - _ -> Nothing - go _ [] = Nothing diff --git a/src/Calamity/Commands/ParsePrefix.hs b/src/Calamity/Commands/ParsePrefix.hs deleted file mode 100644 --- a/src/Calamity/Commands/ParsePrefix.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Command prefix parsing effect -module Calamity.Commands.ParsePrefix - ( ParsePrefix(..) - , parsePrefix - , useConstantPrefix ) where - -import Calamity.Types.Model.Channel.Message - -import Control.Lens - -import qualified Data.Text.Lazy as L - -import qualified Polysemy as P - --- | An effect for parsing the prefix of a command. -data ParsePrefix m a where - -- | Parse a prefix in a message, returning a tuple of @(prefix, remaining message)@ - ParsePrefix :: Message -> ParsePrefix m (Maybe (L.Text, L.Text)) - -P.makeSem ''ParsePrefix - --- | A default interpretation for 'ParsePrefix' that uses a single constant prefix. -useConstantPrefix :: L.Text -> P.Sem (ParsePrefix ': r) a -> P.Sem r a -useConstantPrefix pre = P.interpret (\case - ParsePrefix m -> pure ((pre, ) <$> L.stripPrefix pre (m ^. #content))) diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs deleted file mode 100644 --- a/src/Calamity/Commands/Parser.hs +++ /dev/null @@ -1,350 +0,0 @@ --- | Something that can parse user input -module Calamity.Commands.Parser - ( Parser(..) - , Named - , KleeneStarConcat - , KleenePlusConcat - , ParserEffs - , runCommandParser ) where - -import Calamity.Cache.Eff -import Calamity.Commands.Context -import Calamity.Types.Model.Channel ( Channel, GuildChannel ) -import Calamity.Types.Model.Guild ( Emoji, RawEmoji(..), Partial(PartialEmoji), Guild, Member, Role ) -import Calamity.Types.Model.User ( User ) -import Calamity.Types.Snowflake -import Calamity.Types.Partial - -import Control.Lens hiding ( Context ) -import Control.Monad -import Control.Monad.Trans ( lift ) - -import Data.Char ( isSpace ) -import Data.Kind -import Data.List.NonEmpty ( NonEmpty(..) ) -import Data.Maybe ( isJust ) -import Data.Semigroup -import qualified Data.Text as S -import qualified Data.Text.Lazy as L -import Data.Typeable - -import GHC.Generics ( Generic ) -import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) - -import qualified Polysemy as P -import qualified Polysemy.Error as P -import qualified Polysemy.Reader as P -import qualified Polysemy.State as P - -import Text.Megaparsec hiding ( parse ) -import Text.Megaparsec.Char -import Text.Megaparsec.Error.Builder ( errFancy, fancy ) -import Text.Megaparsec.Char.Lexer (float, decimal, signed) -import Numeric.Natural (Natural) - -data SpannedError = SpannedError L.Text !Int !Int - deriving ( Show, Eq, Ord ) - -showTypeOf :: forall a. Typeable a => String -showTypeOf = show . typeRep $ Proxy @a - -data ParserState = ParserState - { off :: Int - , msg :: L.Text - } - deriving ( Show, Generic ) - -type ParserEffs r = P.State ParserState ': P.Error (S.Text, L.Text) ': P.Reader Context ': r -type ParserCtxE r = P.Reader Context ': r - -runCommandParser :: Context -> L.Text -> P.Sem (ParserEffs r) a -> P.Sem r (Either (S.Text, L.Text) a) -runCommandParser ctx t = P.runReader ctx . P.runError . P.evalState (ParserState 0 t) - -class Typeable a => Parser (a :: Type) r where - type ParserResult a - - type ParserResult a = a - - parserName :: S.Text - default parserName :: S.Text - parserName = ":" <> S.pack (showTypeOf @a) - - parse :: P.Sem (ParserEffs r) (ParserResult a) - --- | A named parameter, used to attach the name @s@ to a type in the command's --- help output -data Named (s :: Symbol) (a :: Type) - -instance (KnownSymbol s, Parser a r) => Parser (Named s a) r where - type ParserResult (Named s a) = ParserResult a - - parserName = (S.pack . symbolVal $ Proxy @s) <> parserName @a @r - - parse = mapE (_1 .~ parserName @(Named s a) @r) $ parse @a @r - -mapE :: P.Member (P.Error e) r => (e -> e) -> P.Sem r a -> P.Sem r a -mapE f m = P.catch m (P.throw . f) - -parseMP :: S.Text -> ParsecT SpannedError L.Text (P.Sem (ParserCtxE r)) a -> P.Sem (ParserEffs r) a -parseMP n m = do - s <- P.get - res <- P.raise . P.raise $ runParserT (skipN (s ^. #off) *> trackOffsets (space *> m)) "" (s ^. #msg) - case res of - Right (a, offset) -> do - P.modify (#off +~ offset) - pure a - Left s -> P.throw (n, L.pack $ errorBundlePretty s) - -instance Parser L.Text r where - parse = parseMP (parserName @L.Text) item - -instance Parser S.Text r where - parse = parseMP (parserName @S.Text) (L.toStrict <$> item) - -instance Parser Integer r where - parse = parseMP (parserName @Integer) (signed mempty decimal) - -instance Parser Natural r where - parse = parseMP (parserName @Natural) decimal - -instance Parser Int r where - parse = parseMP (parserName @Int) (signed mempty decimal) - -instance Parser Word r where - parse = parseMP (parserName @Word) decimal - -instance Parser Float r where - parse = parseMP (parserName @Float) (signed mempty (try float <|> decimal)) - -instance Parser a r => Parser (Maybe a) r where - type ParserResult (Maybe a) = Maybe (ParserResult a) - - parse = P.catch (Just <$> parse @a) (const $ pure Nothing) - - -instance (Parser a r, Parser b r) => Parser (Either a b) r where - type ParserResult (Either a b) = Either (ParserResult a) (ParserResult b) - - parse = do - l <- parse @(Maybe a) @r - case l of - Just l' -> pure (Left l') - Nothing -> - Right <$> parse @b @r - -instance Parser a r => Parser [a] r where - type ParserResult [a] = [ParserResult a] - - parse = go [] - where go :: [ParserResult a] -> P.Sem (ParserEffs r) [ParserResult a] - go l = P.catch (Just <$> parse @a) (const $ pure Nothing) >>= \case - Just a -> go $ l ++ [a] - Nothing -> pure l - -instance (Parser a r, Typeable a) => Parser (NonEmpty a) r where - type ParserResult (NonEmpty a) = NonEmpty (ParserResult a) - - parse = do - a <- parse @a - as <- parse @[a] - pure $ a :| as - --- | A parser that consumes zero or more of @a@ then concatenates them together. --- --- @'KleeneStarConcat' 'L.Text'@ therefore consumes all remaining input. -data KleeneStarConcat (a :: Type) - -instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneStarConcat a) r where - type ParserResult (KleeneStarConcat a) = ParserResult a - - parse = mconcat <$> parse @[a] - -instance {-# OVERLAPS #-}Parser (KleeneStarConcat L.Text) r where - type ParserResult (KleeneStarConcat L.Text) = ParserResult L.Text - - -- consume rest on text just takes everything remaining - parse = parseMP (parserName @(KleeneStarConcat L.Text)) manySingle - -instance {-# OVERLAPS #-}Parser (KleeneStarConcat S.Text) r where - type ParserResult (KleeneStarConcat S.Text) = ParserResult S.Text - - -- consume rest on text just takes everything remaining - parse = parseMP (parserName @(KleeneStarConcat S.Text)) (L.toStrict <$> manySingle) - --- | A parser that consumes one or more of @a@ then concatenates them together. --- --- @'KleenePlusConcat' 'L.Text'@ therefore consumes all remaining input. -data KleenePlusConcat (a :: Type) - -instance (Semigroup (ParserResult a), Parser a r) => Parser (KleenePlusConcat a) r where - type ParserResult (KleenePlusConcat a) = ParserResult a - - parse = sconcat <$> parse @(NonEmpty a) - -instance {-# OVERLAPS #-}Parser (KleenePlusConcat L.Text) r where - type ParserResult (KleenePlusConcat L.Text) = ParserResult L.Text - - -- consume rest on text just takes everything remaining - parse = parseMP (parserName @(KleenePlusConcat L.Text)) someSingle - -instance {-# OVERLAPS #-}Parser (KleenePlusConcat S.Text) r where - type ParserResult (KleenePlusConcat S.Text) = ParserResult S.Text - - -- consume rest on text just takes everything remaining - parse = parseMP (parserName @(KleenePlusConcat S.Text)) (L.toStrict <$> someSingle) - -instance Typeable (Snowflake a) => Parser (Snowflake a) r where - parse = parseMP (parserName @(Snowflake a)) snowflake - --- | Accepts both plain IDs and mentions -instance {-# OVERLAPS #-}Parser (Snowflake User) r where - parse = parseMP (parserName @(Snowflake User)) (try (ping "@") <|> snowflake) - --- | Accepts both plain IDs and mentions -instance {-# OVERLAPS #-}Parser (Snowflake Member) r where - parse = parseMP (parserName @(Snowflake Member)) (try (ping "@") <|> snowflake) - --- | Accepts both plain IDs and mentions -instance {-# OVERLAPS #-}Parser (Snowflake Channel) r where - parse = parseMP (parserName @(Snowflake Channel)) (try (ping "#") <|> snowflake) - --- | Accepts both plain IDs and mentions -instance {-# OVERLAPS #-}Parser (Snowflake Role) r where - parse = parseMP (parserName @(Snowflake Role)) (try (ping "@&") <|> snowflake) - --- | Accepts both plain IDs and uses of emoji -instance {-# OVERLAPS #-}Parser (Snowflake Emoji) r where - parse = parseMP (parserName @(Snowflake Emoji)) (try emoji <|> snowflake) - --- mapParserMaybe :: Stream s => ParsecT SpannedError s m a -> Text -> (a -> Maybe b) -> ParsecT SpannedError s m b --- mapParserMaybe m e f = do --- offs <- getOffset --- r <- f <$> m --- offe <- getOffset --- case r of --- Just r' -> pure r' --- _ -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe - -mapParserMaybeM :: (Monad m, Stream s) => ParsecT SpannedError s m a -> L.Text -> (a -> m (Maybe b)) -> ParsecT SpannedError s m b -mapParserMaybeM m e f = do - offs <- getOffset - r <- m >>= lift . f - offe <- getOffset - case r of - Just r' -> pure r' - Nothing -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe - --- | Parser for members in the guild the command was invoked in, this only looks --- in the cache. Use @'Snowflake' 'Member'@ and use --- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. -instance Parser Member r where - parse = parseMP (parserName @Member) $ mapParserMaybeM (try (ping "@") <|> snowflake) - "Couldn't find a Member with this id" - (\mid -> do - ctx <- P.ask - pure $ ctx ^? #guild . _Just . #members . ix mid) - --- | Parser for users, this only looks in the cache. Use @'Snowflake' --- 'User'@ and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow --- fetching from http. -instance P.Member CacheEff r => Parser User r where - parse = parseMP (parserName @User @r) $ mapParserMaybeM (try (ping "@") <|> snowflake) - "Couldn't find a User with this id" - getUser - --- | Parser for channels in the guild the command was invoked in, this only --- looks in the cache. Use @'Snowflake' 'Channel'@ and use --- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. -instance Parser GuildChannel r where - parse = parseMP (parserName @GuildChannel @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) - "Couldn't find a GuildChannel with this id" - (\cid -> do - ctx <- P.ask - pure $ ctx ^? #guild . _Just . #channels . ix cid) - --- | Parser for guilds, this only looks in the cache. Use @'Snowflake' 'Guild'@ --- and use 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching --- from http. -instance P.Member CacheEff r => Parser Guild r where - parse = parseMP (parserName @Guild @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) - "Couldn't find a Guild with this id" - getGuild - --- | Parser for emojis in the guild the command was invoked in, this only --- looks in the cache. Use @'Snowflake' 'Emoji'@ and use --- 'Calamity.Types.Upgradeable.upgrade' if you want to allow fetching from http. -instance Parser Emoji r where - parse = parseMP (parserName @Emoji @r) $ mapParserMaybeM (try (ping "#") <|> snowflake) - "Couldn't find an Emoji with this id" - (\eid -> do - ctx <- P.ask - pure $ ctx ^? #guild . _Just . #emojis . ix eid) - --- | Parses both discord emojis, and unicode emojis -instance Parser RawEmoji r where - parse = parseMP (parserName @RawEmoji) (try parseCustomEmoji <|> (UnicodeEmoji <$> takeP (Just "A unicode emoji") 1)) - where parseCustomEmoji = CustomEmoji <$> partialEmoji - -instance (Parser a r, Parser b r) => Parser (a, b) r where - type ParserResult (a, b) = (ParserResult a, ParserResult b) - - parse = do - a <- parse @a - b <- parse @b - pure (a, b) - -instance Parser () r where - parse = parseMP (parserName @()) space - -instance ShowErrorComponent SpannedError where - showErrorComponent (SpannedError t _ _) = L.unpack t - errorComponentLen (SpannedError _ s e) = max 1 $ e - s - -skipN :: (Stream s, Ord e) => Int -> ParsecT e s m () -skipN n = void $ takeP Nothing n - -ping :: MonadParsec e L.Text m => L.Text -> m (Snowflake a) -ping c = chunk ("<" <> c) *> optional (chunk "!") *> snowflake <* chunk ">" - -ping' :: MonadParsec e L.Text m => m () -> m (Snowflake a) -ping' m = chunk "<" *> m *> snowflake <* chunk ">" - -snowflake :: MonadParsec e L.Text m => m (Snowflake a) -snowflake = Snowflake <$> decimal - -partialEmoji :: MonadParsec e L.Text m => m (Partial Emoji) -partialEmoji = do - animated <- isJust <$> (chunk "<" *> optional (chunk "a")) - name <- between (chunk ":") (chunk ":") (takeWhileP (Just "Emoji name") $ not . (== ':')) - id <- snowflake - void $ chunk ">" - pure (PartialEmoji id name animated) - -emoji :: MonadParsec e L.Text m => m (Snowflake a) -emoji = ping' (optional (chunk "a") *> between (chunk ":") (chunk ":") (void $ takeWhileP Nothing $ not . (== ':'))) - -trackOffsets :: MonadParsec e s m => m a -> m (a, Int) -trackOffsets m = do - offs <- getOffset - a <- m - offe <- getOffset - pure (a, offe - offs) - -item :: MonadParsec e L.Text m => m L.Text -item = try quotedString <|> someNonWS - -manySingle :: MonadParsec e s m => m (Tokens s) -manySingle = takeWhileP (Just "Any character") (const True) - -someSingle :: MonadParsec e s m => m (Tokens s) -someSingle = takeWhile1P (Just "any character") (const True) - -quotedString :: MonadParsec e L.Text m => m L.Text -quotedString = try (between (chunk "'") (chunk "'") (takeWhileP (Just "any character") $ not . (== '\''))) <|> - between (chunk "\"") (chunk "\"") (takeWhileP (Just "any character") $ not . (== '"')) - --- manyNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s) --- manyNonWS = takeWhileP (Just "Any Non-Whitespace") (not . isSpace) - -someNonWS :: (Token s ~ Char, MonadParsec e s m) => m (Tokens s) -someNonWS = takeWhile1P (Just "any non-whitespace") (not . isSpace) diff --git a/src/Calamity/Commands/Utils.hs b/src/Calamity/Commands/Utils.hs deleted file mode 100644 --- a/src/Calamity/Commands/Utils.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} --- | Command handler utilities -module Calamity.Commands.Utils - ( addCommands - , buildCommands - , buildContext - , handleCommands - , findCommand - , CmdInvokeFailReason(..) ) where - -import Calamity.Cache.Eff -import Calamity.Metrics.Eff -import Calamity.Client.Client -import Calamity.Client.Types -import Calamity.Commands.AliasType -import Calamity.Commands.Command -import Calamity.Commands.CommandUtils -import Calamity.Commands.Context -import Calamity.Commands.Dsl -import Calamity.Commands.Handler -import Calamity.Commands.Error -import Calamity.Commands.Group -import Calamity.Commands.ParsePrefix -import Calamity.Internal.LocalWriter -import Calamity.Internal.Utils -import Calamity.Types.Model.Channel -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Control.Lens hiding ( Context ) -import Control.Monad - -import Data.Char ( isSpace ) -import qualified Data.HashMap.Lazy as LH -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import qualified Polysemy as P -import qualified Polysemy.Error as P -import qualified Polysemy.Fail as P -import qualified Polysemy.Tagged as P -import qualified Polysemy.Fixpoint as P -import qualified Polysemy.Reader as P - -mapLeft :: (e -> e') -> Either e a -> Either e' a -mapLeft f (Left x) = Left $ f x -mapLeft _ (Right x) = Right x - -data CmdInvokeFailReason - = NoContext - | NotFound [L.Text] - | CommandInvokeError Context CommandError - --- | 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. '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. @"command-error" ('Context', 'CommandError')@ --- --- Fired when a command returns an error. --- --- 2. @"command-not-found" ('Calamity.Types.Model.Channel.Message', ['Data.Text.Lazy.Text'])@ --- --- Fired when a valid prefix is used, but the command is not found. --- --- 3. @"command-invoked" 'Context'@ --- --- Fired when a command is successfully invoked. --- -addCommands :: (BotC r, P.Member ParsePrefix r) => P.Sem (DSLState r) a -> P.Sem r (P.Sem r (), CommandHandler, a) -addCommands m = do - (handler, res) <- buildCommands m - remove <- react @'MessageCreateEvt $ \msg -> do - parsePrefix msg >>= \case - Just (prefix, cmd) -> do - r <- handleCommands handler msg prefix cmd - case r of - Left (CommandInvokeError ctx e) -> fire $ customEvt @"command-error" (ctx, e) - Left (NotFound path) -> fire $ customEvt @"command-not-found" (msg, path) - Left NoContext -> pure () -- ignore if context couldn't be built - Right ctx -> do - cmdInvoke <- registerCounter "commands_invoked" [("name", S.unwords $ commandPath (ctx ^. #command))] - void $ addCounter 1 cmdInvoke - fire $ customEvt @"command-invoked" ctx - Nothing -> pure () - pure (remove, handler, res) - --- | Manages parsing messages and handling commands for a CommandHandler. --- --- Returns Right if the command succeeded in parsing and running, Left with the --- reason otherwise. -handleCommands :: (BotC r, P.Member ParsePrefix r) - => CommandHandler - -> Message -- ^ The message that invoked the command - -> L.Text -- ^ The prefix used - -> L.Text -- ^ The command string, without a prefix - -> P.Sem r (Either CmdInvokeFailReason Context) -handleCommands handler msg prefix cmd = P.runError $ do - (command, unparsedParams) <- P.fromEither $ mapLeft NotFound $ findCommand handler cmd - ctx <- P.note NoContext =<< buildContext msg prefix command unparsedParams - P.fromEither . mapLeft (CommandInvokeError ctx) =<< invokeCommand ctx (ctx ^. #command) - pure ctx - - --- | Run a command DSL, returning the constructed 'CommandHandler' -buildCommands :: forall r a. P.Member (P.Final IO) r - => P.Sem (DSLState r) a - -> P.Sem r (CommandHandler, a) -buildCommands m = P.fixpointToFinal $ mdo - (groups, (cmds, a)) <- inner handler m - let handler = CommandHandler groups cmds - pure (handler, a) - - where inner :: CommandHandler -> P.Sem (DSLState r) a - -> P.Sem (P.Fixpoint ': r) (LH.HashMap S.Text (Group, AliasType), - (LH.HashMap S.Text (Command, AliasType), a)) - inner h = - P.runReader h . - P.runReader [] . - P.runReader defaultHelp . P.untag @"original-help" . - P.runReader defaultHelp . - P.runReader False . P.untag @"hidden" . - P.runReader Nothing . - runLocalWriter @(LH.HashMap S.Text (Group, AliasType)) . - runLocalWriter @(LH.HashMap S.Text (Command, AliasType)) - defaultHelp = (const "This command or group has no help.") - --- TODO: turn this into an effect --- | Attempt to build the context for a command -buildContext :: BotC r => Message -> L.Text -> Command -> L.Text -> P.Sem r (Maybe Context) -buildContext msg prefix command unparsed = (rightToMaybe <$>) . P.runFail $ do - guild <- join <$> getGuild `traverse` (msg ^. #guildID) - let member = guild ^? _Just . #members . ix (coerceSnowflake $ getID @User msg) - let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg) - Just channel <- case gchan of - Just chan -> pure . pure $ GuildChannel' chan - Nothing -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg) - Just user <- getUser $ getID msg - - pure $ Context msg guild member channel user command prefix unparsed - -nextWord :: L.Text -> (L.Text, L.Text) -nextWord = L.break isSpace . L.stripStart - --- | Attempt to find what command was used. --- --- On error: returns the path of existing groups that were found, so @"group0 --- group1 group2 notacommand"@ will error with @Left ["group0", "group1", --- "group2"]@ --- --- On success: returns the command that was invoked, and the remaining text --- after it. --- --- This function isn't greedy, if you have a group and a command at the same --- level, this will find the command first and ignore the group. -findCommand :: CommandHandler -> L.Text -> Either [L.Text] (Command, L.Text) -findCommand handler msg = goH $ nextWord msg - where - goH :: (L.Text, L.Text) -> Either [L.Text] (Command, L.Text) - goH ("", _) = Left [] - goH (x, xs) = attachSoFar x - (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (handler ^. #commands))) - <> (attachInitial (LH.lookup (L.toStrict x) (handler ^. #groups)) >>= goG (nextWord xs))) - - goG :: (L.Text, L.Text) -> Group -> Either [L.Text] (Command, L.Text) - goG ("", _) _ = Left [] - goG (x, xs) g = attachSoFar x - (((, xs) <$> attachInitial (LH.lookup (L.toStrict x) (g ^. #commands))) - <> (attachInitial (LH.lookup (L.toStrict x) (g ^. #children)) >>= goG (nextWord xs))) - - attachInitial :: Maybe (a, b) -> Either [L.Text] a - attachInitial (Just (a, _)) = Right a - attachInitial Nothing = Left [] - - attachSoFar :: L.Text -> Either [L.Text] a -> Either [L.Text] a - attachSoFar cmd (Left xs) = Left (cmd:xs) - attachSoFar _ r = r diff --git a/src/Calamity/Gateway.hs b/src/Calamity/Gateway.hs deleted file mode 100644 --- a/src/Calamity/Gateway.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | -module Calamity.Gateway - ( module Calamity.Gateway.Shard - , module Calamity.Gateway.Types - , module Calamity.Gateway.Intents - -- * Gateway - -- $gatewayDocs - ) where - -import Calamity.Gateway.Shard -import Calamity.Gateway.Types -import Calamity.Gateway.Intents - --- $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/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs deleted file mode 100644 --- a/src/Calamity/Gateway/DispatchEvents.hs +++ /dev/null @@ -1,235 +0,0 @@ --- | module containing all dispatch events -module Calamity.Gateway.DispatchEvents where - -import Calamity.Internal.AesonThings -import Calamity.Internal.ConstructorName -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Channel.UpdatedMessage -import Calamity.Types.Model.Guild.Ban -import Calamity.Types.Model.Guild.Emoji -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Member -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.Guild.UnavailableGuild -import Calamity.Types.Model.Presence.Presence -import Calamity.Types.Model.User -import Calamity.Types.Snowflake -import Calamity.Types.UnixTimestamp - -import Data.Aeson -import Data.Dynamic -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Typeable -import Data.Vector.Unboxing ( Vector ) - -import GHC.Generics - -data CalamityEvent - = Dispatch - Int -- ^ The shard that pushed this event - DispatchData -- ^ The attached data - | Custom - TypeRep -- ^ The name of the custom event - Dynamic -- ^ The data sent to the custom event - | ShutDown - deriving ( Show, Generic ) - -data DispatchData - = Ready ReadyData - | Resumed - | ChannelCreate Channel - | ChannelUpdate Channel - | ChannelDelete Channel - | ChannelPinsUpdate ChannelPinsUpdateData - | GuildCreate Guild - | GuildUpdate UpdatedGuild - | GuildDelete UnavailableGuild - | GuildBanAdd BanData - | GuildBanRemove BanData - | GuildEmojisUpdate GuildEmojisUpdateData - | GuildIntegrationsUpdate GuildIntegrationsUpdateData - | GuildMemberAdd Member - | GuildMemberRemove GuildMemberRemoveData - | GuildMemberUpdate GuildMemberUpdateData - | GuildMembersChunk GuildMembersChunkData - | GuildRoleCreate GuildRoleData - | GuildRoleUpdate GuildRoleData - | GuildRoleDelete GuildRoleDeleteData - | InviteCreate InviteCreateData - | InviteDelete InviteDeleteData - | MessageCreate Message - | MessageUpdate UpdatedMessage - | MessageDelete MessageDeleteData - | MessageDeleteBulk MessageDeleteBulkData - | MessageReactionAdd Reaction - | MessageReactionRemove Reaction - | MessageReactionRemoveAll MessageReactionRemoveAllData - | PresenceUpdate PresenceUpdateData - | TypingStart TypingStartData - | UserUpdate User - | VoiceStateUpdate VoiceStateUpdateData - | VoiceServerUpdate VoiceServerUpdateData - | WebhooksUpdate WebhooksUpdateData - deriving ( Show, Generic, CtorName ) - -data ReadyData = ReadyData - { v :: Integer - , user :: User - , guilds :: [UnavailableGuild] - , sessionID :: Text - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON ReadyData - -data ChannelPinsUpdateData = ChannelPinsUpdateData - { channelID :: Snowflake Channel - , lastPinTimestamp :: Maybe UTCTime - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON ChannelPinsUpdateData - -data GuildEmojisUpdateData = GuildEmojisUpdateData - { guildID :: Snowflake Guild - , emojis :: [Emoji] - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON GuildEmojisUpdateData - -newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData - { guildID :: Snowflake Guild - } - deriving newtype ( Show, Generic ) - deriving FromJSON via CalamityJSON GuildIntegrationsUpdateData - -data GuildMemberRemoveData = GuildMemberRemoveData - { guildID :: Snowflake Guild - , user :: User - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON GuildMemberRemoveData - -data GuildMemberUpdateData = GuildMemberUpdateData - { guildID :: Snowflake Guild - , roles :: Vector (Snowflake Role) - , user :: User - , nick :: Maybe Text - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON GuildMemberUpdateData - -data GuildMembersChunkData = GuildMembersChunkData - { guildID :: Snowflake Guild - , members :: [Member] - } - deriving ( Show, Generic ) - -instance FromJSON GuildMembersChunkData where - parseJSON = withObject "GuildMembersChunkData" $ \v -> do - guildID <- v .: "guild_id" - - members' <- do - members' <- v .: "members" - traverse (\m -> parseJSON $ Object (m <> "guild_id" .= guildID)) members' - - pure $ GuildMembersChunkData guildID members' - -data GuildRoleData = GuildRoleData - { guildID :: Snowflake Guild - , role :: Role - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON GuildRoleData - -data GuildRoleDeleteData = GuildRoleDeleteData - { guildID :: Snowflake Guild - , roleID :: Snowflake Role - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON GuildRoleDeleteData - -data InviteCreateData = InviteCreateData - { channelID :: Snowflake Channel - , code :: Text - , createdAt :: UnixTimestamp - , guildID :: Maybe (Snowflake Guild) - , inviter :: Maybe (Snowflake User) - , maxAge :: Int - , maxUses :: Int - , targetUser :: Maybe (Snowflake User) - , targetUserType :: Maybe Integer - , temporary :: Bool - , uses :: Integer - } - deriving ( Show, Generic ) - deriving ( FromJSON ) via WithSpecialCases - '["inviter" `ExtractFieldFrom` "id", "targetUser" `ExtractFieldFrom` "id"] - InviteCreateData - -data InviteDeleteData = InviteDeleteData - { channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , code :: Text - } - deriving ( Show, Generic ) - deriving ( FromJSON ) via CalamityJSON InviteDeleteData - -data MessageDeleteData = MessageDeleteData - { id :: Snowflake Message - , channelID :: Snowflake Channel - , guildID :: Snowflake Guild - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON MessageDeleteData - -data MessageDeleteBulkData = MessageDeleteBulkData - { guildID :: Snowflake Guild - , channelID :: Snowflake Channel - , ids :: [Snowflake Message] - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON MessageDeleteBulkData - -data MessageReactionRemoveAllData = MessageReactionRemoveAllData - { channelID :: Snowflake Channel - , messageID :: Snowflake Message - , guildID :: Maybe (Snowflake Guild) - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON MessageReactionRemoveAllData - -data PresenceUpdateData = PresenceUpdateData - { userID :: Snowflake User - , roles :: Vector (Snowflake Role) - , presence :: Presence - } - deriving ( Show, Generic ) - -instance FromJSON PresenceUpdateData where - parseJSON = withObject "PresenceUpdate" $ \v -> do - user <- (v .: "user") >>= (.: "id") - roles <- v .: "roles" - presence <- parseJSON $ Object v - pure $ PresenceUpdateData user roles presence - -data TypingStartData = TypingStartData - { channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , userID :: Snowflake User - , timestamp :: UnixTimestamp - } - deriving ( Show, Generic ) - deriving FromJSON via CalamityJSON TypingStartData - -newtype VoiceStateUpdateData = VoiceStateUpdateData Value - deriving newtype ( Show, Generic ) - deriving newtype ( ToJSON, FromJSON ) - -newtype VoiceServerUpdateData = VoiceServerUpdateData Value - deriving newtype ( Show, Generic ) - deriving newtype ( ToJSON, FromJSON ) - -newtype WebhooksUpdateData = WebhooksUpdateData Value - deriving newtype ( Show, Generic ) - deriving newtype ( ToJSON, FromJSON ) diff --git a/src/Calamity/Gateway/Intents.hs b/src/Calamity/Gateway/Intents.hs deleted file mode 100644 --- a/src/Calamity/Gateway/Intents.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE NoDeriveAnyClass #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Discord gateway intents -module Calamity.Gateway.Intents - ( Intents(..) - , intentGuilds - , intentGuildMembers - , intentGuildBans - , intentGuildEmojis - , intentGuildIntegrations - , intentGuildWebhooks - , intentGuildInvites - , intentGuildVoiceStates - , intentGuildPresences - , intentGuildMessages - , intentGuildMessageReactions - , intentGuildMessageTyping - , intentDirectMessages - , intentDirectMessageReactions - , intentDirectMessageTyping ) where - -import Data.Aeson ( ToJSON ) -import Data.Bits -import Data.Flags () -import Data.Flags.TH -import Data.Word - -$(bitmaskWrapper "Intents" ''Word32 [] - [ ("intentGuilds", 1 `shiftL` 0) - , ("intentGuildMembers", 1 `shiftL` 1) - , ("intentGuildBans", 1 `shiftL` 2) - , ("intentGuildEmojis", 1 `shiftL` 3) - , ("intentGuildIntegrations", 1 `shiftL` 4) - , ("intentGuildWebhooks", 1 `shiftL` 5) - , ("intentGuildInvites", 1 `shiftL` 6) - , ("intentGuildVoiceStates", 1 `shiftL` 7) - , ("intentGuildPresences", 1 `shiftL` 8) - , ("intentGuildMessages", 1 `shiftL` 9) - , ("intentGuildMessageReactions", 1 `shiftL` 10) - , ("intentGuildMessageTyping", 1 `shiftL` 11) - , ("intentDirectMessages", 1 `shiftL` 12) - , ("intentDirectMessageReactions", 1 `shiftL` 13) - , ("intentDirectMessageTyping", 1 `shiftL` 14)]) - -deriving via Word32 instance ToJSON Intents diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs deleted file mode 100644 --- a/src/Calamity/Gateway/Shard.hs +++ /dev/null @@ -1,319 +0,0 @@ --- | The shard logic -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} - -module Calamity.Gateway.Shard - ( Shard(..) - , newShard ) where - -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Intents -import Calamity.Gateway.Types -import Calamity.Internal.Utils -import Calamity.Internal.RunIntoIO -import Calamity.Metrics.Eff -import Calamity.Types.LogEff -import Calamity.Types.Token - -import Control.Concurrent -import Control.Concurrent.Async -import qualified Control.Concurrent.Chan.Unagi as UC -import Control.Concurrent.STM -import Control.Concurrent.STM.TBMQueue -import Control.Exception -import qualified Control.Exception.Safe as Ex -import Control.Lens -import Control.Monad -import Control.Monad.State.Lazy - -import qualified Data.Aeson as A -import Data.Functor -import Data.IORef -import Data.Maybe -import qualified Data.Text.Lazy as L - -import DiPolysemy hiding ( debug, error, info ) - -import Fmt - -import Network.WebSockets ( Connection, ConnectionException(..), receiveData, sendCloseCode - , sendTextData ) - -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 Prelude hiding ( error ) - -import Wuss - -runWebsocket :: P.Members '[P.Final IO, P.Embed IO] r - => L.Text - -> L.Text - -> (Connection -> P.Sem r a) - -> P.Sem r (Maybe a) -runWebsocket host path ma = do - inner <- bindSemToIO ma - P.embed $ runSecureClient (L.unpack host) 443 (L.unpack path) inner - -newShardState :: Shard -> ShardState -newShardState shard = ShardState shard Nothing Nothing False Nothing Nothing Nothing - --- | Creates and launches a shard -newShard :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r - => L.Text - -> Int - -> Int - -> Token - -> Maybe StatusUpdateData - -> Maybe Intents - -> UC.InChan CalamityEvent - -> Sem r (UC.InChan ControlMessage, Async (Maybe ())) -newShard gateway id count token presence intents evtIn = do - (cmdIn, stateVar) <- P.embed $ mdo - (cmdIn, cmdOut) <- UC.newChan - stateVar <- newIORef $ newShardState shard - let shard = Shard id count gateway evtIn cmdOut stateVar (rawToken token) presence intents - pure (cmdIn, stateVar) - - let runShard = P.runAtomicStateIORef stateVar shardLoop - let action = push "calamity-shard" . attr "shard-id" id $ runShard - - thread' <- P.async action - - pure (cmdIn, thread') - -sendToWs :: ShardC r => SentDiscordMessage -> Sem r () -sendToWs data' = do - wsConn' <- P.atomicGets wsConn - case wsConn' of - Just wsConn -> do - let encodedData = A.encode data' - debug $ "sending " +|| data' ||+ " encoded to " +|| encodedData ||+ " to gateway" - P.embed . sendTextData wsConn $ encodedData - Nothing -> debug "tried to send to closed WS" - -tryWriteTBMQueue' :: TBMQueue a -> a -> STM Bool -tryWriteTBMQueue' q v = do - v' <- tryWriteTBMQueue q v - case v' of - Just False -> retry - Just True -> pure True - Nothing -> pure False - -restartUnless :: P.Members '[LogEff, P.Error ShardFlowControl] r => L.Text -> Maybe a -> P.Sem r a -restartUnless _ (Just a) = pure a -restartUnless msg Nothing = do - error msg - P.throw ShardFlowRestart - --- | The loop a shard will run on -shardLoop :: ShardC r => Sem r () -shardLoop = do - activeShards <- registerGauge "active_shards" mempty - void $ modifyGauge (+ 1) activeShards - void outerloop - void $ modifyGauge (subtract 1) activeShards - debug "Shard shut down" - where - controlStream :: Shard -> TBMQueue ShardMsg -> IO () - controlStream shard outqueue = inner - where - q = shard ^. #cmdOut - inner = do - v <- UC.readChan q - r <- atomically $ tryWriteTBMQueue' outqueue (Control v) - when r inner - - handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe L.Text) a) - handleWSException e = pure $ case fromException e of - Just (CloseRequest code _) - | code `elem` [1000, 4004, 4010, 4011] -> - Left (ShutDownShard, Nothing) - e -> Left (RestartShard, Just . L.pack . show $ e) - - discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r () - discordStream ws outqueue = inner - where inner = do - msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException - - case msg of - Left (c, reason) -> do - whenJust reason (\r -> error $ "Shard closed with reason: " <> r) - P.embed . atomically $ writeTBMQueue outqueue (Control c) - - Right msg' -> do - let decoded = A.eitherDecode msg' - r <- case decoded of - Right a -> - P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) - Left e -> do - error $ "Failed to decode: "+|e|+"" - pure True - when r inner - - -- | The outer loop, sets up the ws conn, etc handles reconnecting and such - outerloop :: ShardC r => Sem r () - outerloop = whileMFinalIO $ do - shard :: Shard <- P.atomicGets (^. #shardS) - let host = shard ^. #gateway - let host' = fromMaybe host $ L.stripPrefix "wss://" host - info $ "starting up shard "+| (shard ^. #shardID) |+" of "+| (shard ^. #shardCount) |+"" - - innerLoopVal <- runWebsocket host' "/?v=6&encoding=json" innerloop - - case innerLoopVal of - Just ShardFlowShutDown -> do - info "Shutting down shard" - pure False - - Just ShardFlowRestart -> do - info "Restaring shard" - pure True - -- we restart normally when we loop - - Nothing -> do -- won't happen unless innerloop starts using a non-deterministic effect - info "Restarting shard (abnormal reasons?)" - pure True - - -- | The inner loop, handles receiving a message from discord or a command message - -- and then decides what to do with it - innerloop :: ShardC r => Connection -> Sem r ShardFlowControl - innerloop ws = do - debug "Entering inner loop of shard" - - shard <- P.atomicGets (^. #shardS) - P.atomicModify (#wsConn ?~ ws) - - seqNum' <- P.atomicGets (^. #seqNum) - sessionID' <- P.atomicGets (^. #sessionID) - - case (seqNum', sessionID') of - (Just n, Just s) -> do - debug $ "Resuming shard (sessionID: "+|s|+", seq: "+|n|+")" - sendToWs (Resume ResumeData - { token = shard ^. #token - , sessionID = s - , seq = n - }) - _noActiveSession -> do - debug "Identifying shard" - sendToWs (Identify IdentifyData - { token = shard ^. #token - , properties = IdentifyProps - { browser = "Calamity: https://github.com/nitros12/calamity" - , device = "Calamity: https://github.com/nitros12/calamity" - } - , compress = False - , largeThreshold = 250 - , shard = (shard ^. #shardID, - shard ^. #shardCount) - , presence = shard ^. #initialStatus - , intents = shard ^. #intents - }) - - result <- P.resourceToIOFinal $ P.bracket (P.embed $ newTBMQueueIO 1) - (P.embed . atomically . closeTBMQueue) - (\q -> do - debug "handling events now" - _controlThread <- P.async . P.embed $ controlStream shard q - _discordThread <- P.async $ discordStream ws q - P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do - -- only we close the queue - msg <- P.embed . atomically $ readTBMQueue q - handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg) - - debug "Exiting inner loop of shard" - - P.atomicModify (#wsConn .~ Nothing) - haltHeartBeat - pure result - - -- | Handlers for each message, not sure what they'll need to do exactly yet - handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r () - handleMsg (Discord msg) = case msg of - EvtDispatch sn data' -> do - -- trace $ "Handling event: ("+||data'||+")" - P.atomicModify (#seqNum ?~ sn) - - case data' of - Ready rdata' -> - P.atomicModify (#sessionID ?~ (rdata' ^. #sessionID)) - - _NotReady -> pure () - - shard <- P.atomicGets (^. #shardS) - P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data') - - HeartBeatReq -> do - debug "Received heartbeat request" - sendHeartBeat - - Reconnect -> do - debug "Being asked to restart by Discord" - P.throw ShardFlowRestart - - InvalidSession resumable -> do - if resumable - then - info "Received resumable invalid session" - else do - info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" - P.atomicModify (#sessionID .~ Nothing) - P.atomicModify (#seqNum .~ Nothing) - P.embed $ threadDelay (15 * 1000 * 1000) - P.throw ShardFlowRestart - - Hello interval -> do - info $ "Received hello, beginning to heartbeat at an interval of "+|interval|+"ms" - startHeartBeatLoop interval - - HeartBeatAck -> do - debug "Received heartbeat ack" - P.atomicModify (#hbResponse .~ True) - - handleMsg (Control msg) = case msg of - SendPresence data' -> do - debug $ "Sending presence: ("+||data'||+")" - sendToWs $ StatusUpdate data' - - RestartShard -> P.throw ShardFlowRestart - ShutDownShard -> P.throw ShardFlowShutDown - -startHeartBeatLoop :: ShardC r => Int -> Sem r () -startHeartBeatLoop interval = do - haltHeartBeat -- cancel any currently running hb thread - thread <- P.async $ heartBeatLoop interval - P.atomicModify (#hbThread ?~ thread) - -haltHeartBeat :: ShardC r => Sem r () -haltHeartBeat = do - thread <- P.atomicState @ShardState . (swap .) . runState $ do - thread <- use #hbThread - #hbThread .= Nothing - pure thread - case thread of - Just t -> do - debug "Stopping heartbeat thread" - P.embed (void $ cancel t) - Nothing -> pure () - -sendHeartBeat :: ShardC r => Sem r () -sendHeartBeat = do - sn <- P.atomicGets (^. #seqNum) - debug $ "Sending heartbeat (seq: " +|| sn ||+ ")" - sendToWs $ HeartBeat sn - P.atomicModify (#hbResponse .~ False) - -heartBeatLoop :: ShardC r => Int -> Sem r () -heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do - sendHeartBeat - P.embed . threadDelay $ interval * 1000 - unlessM (P.atomicGets (^. #hbResponse)) $ do - debug "No heartbeat response, restarting shard" - wsConn <- P.note () =<< P.atomicGets (^. #wsConn) - P.embed $ sendCloseCode wsConn 4000 ("No heartbeat in time" :: L.Text) - P.throw () diff --git a/src/Calamity/Gateway/Types.hs b/src/Calamity/Gateway/Types.hs deleted file mode 100644 --- a/src/Calamity/Gateway/Types.hs +++ /dev/null @@ -1,284 +0,0 @@ --- | Types for shards -module Calamity.Gateway.Types - ( ShardC - , ShardMsg(..) - , ReceivedDiscordMessage(..) - , SentDiscordMessage(..) - , DispatchType(..) - , IdentifyData(..) - , StatusUpdateData(..) - , ResumeData(..) - , RequestGuildMembersData(..) - , IdentifyProps(..) - , ControlMessage(..) - , ShardFlowControl(..) - , Shard(..) - , ShardState(..) ) where - -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Intents -import Calamity.Internal.AesonThings -import Calamity.Metrics.Eff -import Calamity.Types.LogEff -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Voice -import Calamity.Types.Model.Presence.Activity -import Calamity.Types.Snowflake - -import Control.Concurrent.Async -import Control.Concurrent.Chan.Unagi - -import Data.Aeson -import qualified Data.Aeson.Types as AT -import Data.Generics.Labels () -import Data.IORef -import Data.Maybe -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import Network.WebSockets.Connection ( Connection ) - -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.AtomicState as P -import qualified TextShow.Generic as TSG -import TextShow (TextShow) - -type ShardC r = (P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO, - P.Async, MetricEff] r) - -data ShardMsg - = Discord ReceivedDiscordMessage - | Control ControlMessage - deriving ( Show, Generic ) - -data ReceivedDiscordMessage - = EvtDispatch Int !DispatchData - | HeartBeatReq - | Reconnect - | InvalidSession Bool - | Hello Int - | HeartBeatAck - deriving ( Show, Generic ) - -instance FromJSON ReceivedDiscordMessage where - parseJSON = withObject "ReceivedDiscordMessage" $ \v -> do - op :: Int <- v .: "op" - case op of - 0 -> do - d <- v .: "d" - t <- v .: "t" - s <- v .: "s" - EvtDispatch s <$> parseDispatchData t d - - 1 -> pure HeartBeatReq - - 7 -> pure Reconnect - - 9 -> InvalidSession <$> v .: "d" - - 10 -> Hello <$> do - d <- v .: "d" - d .: "heartbeat_interval" - - 11 -> pure HeartBeatAck - - _ -> fail $ "invalid opcode: " <> show op - -parseDispatchData :: DispatchType -> Value -> AT.Parser DispatchData -parseDispatchData READY data' = Ready <$> parseJSON data' -parseDispatchData RESUMED _ = pure Resumed -parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> parseJSON data' -parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> parseJSON data' -parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> parseJSON data' -parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> parseJSON data' -parseDispatchData GUILD_CREATE data' = GuildCreate <$> parseJSON data' -parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> parseJSON data' -parseDispatchData GUILD_DELETE data' = GuildDelete <$> parseJSON data' -parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> parseJSON data' -parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> parseJSON data' -parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> parseJSON data' -parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> parseJSON data' -parseDispatchData GUILD_MEMBER_ADD data' = GuildMemberAdd <$> parseJSON data' -parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> parseJSON data' -parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> parseJSON data' -parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> parseJSON data' -parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> parseJSON data' -parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> parseJSON data' -parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> parseJSON data' -parseDispatchData INVITE_CREATE data' = InviteCreate <$> parseJSON data' -parseDispatchData INVITE_DELETE data' = InviteDelete <$> parseJSON data' -parseDispatchData MESSAGE_CREATE data' = MessageCreate <$> parseJSON data' -parseDispatchData MESSAGE_UPDATE data' = MessageUpdate <$> parseJSON data' -parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data' -parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> parseJSON data' -parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> parseJSON data' -parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> parseJSON data' -parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> parseJSON data' -parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> parseJSON data' -parseDispatchData TYPING_START data' = TypingStart <$> parseJSON data' -parseDispatchData USER_UPDATE data' = UserUpdate <$> parseJSON data' -parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> parseJSON data' -parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> parseJSON data' -parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> parseJSON data' - -data SentDiscordMessage - = StatusUpdate StatusUpdateData - | Identify IdentifyData - | HeartBeat (Maybe Int) - | VoiceStatusUpdate VoiceState - | Resume ResumeData - | RequestGuildMembers RequestGuildMembersData - deriving ( Show, Generic ) - -instance ToJSON SentDiscordMessage where - toJSON (HeartBeat data') = object ["op" .= (1 :: Int), "d" .= data'] - - toJSON (Identify data') = object ["op" .= (2 :: Int), "d" .= data'] - - toJSON (StatusUpdate data') = object ["op" .= (3 :: Int), "d" .= data'] - - toJSON (VoiceStatusUpdate data') = object ["op" .= (4 :: Int), "d" .= data'] - - toJSON (Resume data') = object ["op" .= (6 :: Int), "d" .= data'] - - toJSON (RequestGuildMembers data') = object ["op" .= (8 :: Int), "d" .= data'] - - toEncoding (HeartBeat data') = pairs ("op" .= (1 :: Int) <> "d" .= data') - - toEncoding (Identify data') = pairs ("op" .= (2 :: Int) <> "d" .= data') - - toEncoding (StatusUpdate data') = pairs ("op" .= (3 :: Int) <> "d" .= data') - - toEncoding (VoiceStatusUpdate data') = pairs ("op" .= (4 :: Int) <> "d" .= data') - - toEncoding (Resume data') = pairs ("op" .= (6 :: Int) <> "d" .= data') - - toEncoding (RequestGuildMembers data') = pairs ("op" .= (8 :: Int) <> "d" .= data') - --- Thanks sbrg: --- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs -data DispatchType - = READY - | RESUMED - | CHANNEL_CREATE - | CHANNEL_UPDATE - | CHANNEL_DELETE - | CHANNEL_PINS_UPDATE - | GUILD_CREATE - | GUILD_UPDATE - | GUILD_DELETE - | GUILD_BAN_ADD - | GUILD_BAN_REMOVE - | GUILD_EMOJIS_UPDATE - | GUILD_INTEGRATIONS_UPDATE - | GUILD_MEMBER_ADD - | GUILD_MEMBER_REMOVE - | GUILD_MEMBER_UPDATE - | GUILD_MEMBERS_CHUNK - | GUILD_ROLE_CREATE - | GUILD_ROLE_UPDATE - | GUILD_ROLE_DELETE - | INVITE_CREATE - | INVITE_DELETE - | MESSAGE_CREATE - | MESSAGE_UPDATE - | MESSAGE_DELETE - | MESSAGE_DELETE_BULK - | MESSAGE_REACTION_ADD - | MESSAGE_REACTION_REMOVE - | MESSAGE_REACTION_REMOVE_ALL - | PRESENCE_UPDATE - | TYPING_START - | USER_UPDATE - | VOICE_STATE_UPDATE - | VOICE_SERVER_UPDATE - | WEBHOOKS_UPDATE - deriving ( Show, Eq, Enum, Generic ) - deriving anyclass ( ToJSON, FromJSON ) - -data IdentifyData = IdentifyData - { token :: Text - , properties :: IdentifyProps - , compress :: Bool - , largeThreshold :: Int - , shard :: (Int, Int) - , presence :: Maybe StatusUpdateData - , intents :: Maybe Intents - } - deriving ( Show, Generic ) - deriving ToJSON via CalamityJSON IdentifyData - -data StatusUpdateData = StatusUpdateData - { since :: Maybe Integer - , game :: Maybe Activity - , status :: Text - , afk :: Bool - } - deriving ( Show, Generic ) - deriving ToJSON via CalamityJSONKeepNothing StatusUpdateData - -data ResumeData = ResumeData - { token :: Text - , sessionID :: Text - , seq :: Int - } - deriving ( Show, Generic ) - deriving ( ToJSON, FromJSON ) via CalamityJSON ResumeData - -data RequestGuildMembersData = RequestGuildMembersData - { guildID :: Snowflake Guild - , query :: Maybe Text - , limit :: Maybe Int - } - deriving ( Show, Generic ) - -instance ToJSON RequestGuildMembersData where - toJSON RequestGuildMembersData { guildID, query, limit } = - object ["guild_id" .= guildID, "query" .= fromMaybe "" query, "limit" .= fromMaybe 0 limit] - -data IdentifyProps = IdentifyProps - { browser :: Text - , device :: Text - } - deriving ( Show, Generic ) - -instance ToJSON IdentifyProps where - toJSON IdentifyProps { browser, device } = object ["$browser" .= browser, "$device" .= device] - -data ControlMessage - = RestartShard - | ShutDownShard - | SendPresence StatusUpdateData - deriving ( Show, Generic ) - -data ShardFlowControl - = ShardFlowRestart - | ShardFlowShutDown - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ShardFlowControl - -data Shard = Shard - { shardID :: Int - , shardCount :: Int - , gateway :: Text - , evtIn :: InChan CalamityEvent - , cmdOut :: OutChan ControlMessage - , shardState :: IORef ShardState - , token :: Text - , initialStatus :: Maybe StatusUpdateData - , intents :: Maybe Intents - } - deriving ( Generic ) - -data ShardState = ShardState - { shardS :: Shard - , seqNum :: Maybe Int - , hbThread :: Maybe (Async (Maybe ())) - , hbResponse :: Bool - , wsHost :: Maybe Text - , sessionID :: Maybe Text - , wsConn :: Maybe Connection - } - deriving ( Generic ) diff --git a/src/Calamity/HTTP.hs b/src/Calamity/HTTP.hs deleted file mode 100644 --- a/src/Calamity/HTTP.hs +++ /dev/null @@ -1,54 +0,0 @@ --- | Combined http request stuff -module Calamity.HTTP - ( module Calamity.HTTP.AuditLog - , module Calamity.HTTP.Internal.Request - , module Calamity.HTTP.Channel - , module Calamity.HTTP.Emoji - , module Calamity.HTTP.Guild - , module Calamity.HTTP.Invite - , module Calamity.HTTP.MiscRoutes - , module Calamity.HTTP.User - , module Calamity.HTTP.Reason - , module Calamity.HTTP.Internal.Types - , module Calamity.HTTP.Webhook - -- * HTTP - -- $httpDocs - ) where - -import Calamity.HTTP.AuditLog -import Calamity.HTTP.Channel -import Calamity.HTTP.Emoji -import Calamity.HTTP.Guild -import Calamity.HTTP.Internal.Request ( invoke ) -import Calamity.HTTP.Internal.Types ( RestError ) -import Calamity.HTTP.Invite -import Calamity.HTTP.MiscRoutes -import Calamity.HTTP.Reason -import Calamity.HTTP.User -import Calamity.HTTP.Webhook - --- $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/src/Calamity/HTTP/AuditLog.hs b/src/Calamity/HTTP/AuditLog.hs deleted file mode 100644 --- a/src/Calamity/HTTP/AuditLog.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | Audit Log endpoints -module Calamity.HTTP.AuditLog - ( AuditLogRequest(..) - , GetAuditLogOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Control.Lens -import Control.Arrow ( (>>>) ) - -import Data.Default.Class -import Data.Maybe ( maybeToList ) - -import GHC.Generics - -import Network.Wreq.Lens - -import TextShow ( showt ) - -data GetAuditLogOptions = GetAuditLogOptions - { userID :: Maybe (Snowflake User) - , actionType :: Maybe AuditLogAction - , before :: Maybe (Snowflake AuditLogEntry) - , limit :: Maybe Integer - } - deriving ( Show, Generic, Default ) - -data AuditLogRequest a where - GetAuditLog :: HasID Guild g => g -> GetAuditLogOptions -> AuditLogRequest AuditLog - -instance Request (AuditLogRequest a) where - type Result (AuditLogRequest a) = a - - route (GetAuditLog (getID @Guild -> gid) _) = mkRouteBuilder // S "guilds" // ID @Guild // S "audit-logs" - & giveID gid - & buildRoute - - action (GetAuditLog _ GetAuditLogOptions { userID, actionType, before, limit }) = getWithP - (param "user_id" .~ maybeToList (showt <$> userID) >>> - param "action_type" .~ maybeToList (showt .fromEnum <$> actionType) >>> - param "before" .~ maybeToList (showt <$> before) >>> - param "limit" .~ maybeToList (showt <$> limit)) diff --git a/src/Calamity/HTTP/Channel.hs b/src/Calamity/HTTP/Channel.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Channel.hs +++ /dev/null @@ -1,286 +0,0 @@ --- | Channel endpoints -module Calamity.HTTP.Channel - ( ChannelRequest(..) - , CreateMessageOptions(..) - , ChannelUpdate(..) - , AllowedMentionType(..) - , AllowedMentions(..) - , ChannelMessagesQuery(..) - , GetReactionsOptions(..) - , CreateChannelInviteOptions(..) - , GroupDMAddRecipientOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Control.Arrow -import Control.Lens hiding ( (.=) ) - -import Data.Aeson -import Data.ByteString.Lazy ( ByteString ) -import Data.Default.Class -import Data.Generics.Product.Subtype ( upcast ) -import Data.Maybe -import qualified Data.Text as S -import qualified Data.Text.Encoding as S -import Data.Text ( Text ) - -import GHC.Generics - -import Network.Wreq ( partLBS ) -import Network.Wreq.Lens -import Network.Wreq.Session -import Network.Mime - -import TextShow -import Network.HTTP.Types (urlEncode) - -data CreateMessageOptions = CreateMessageOptions - { content :: Maybe Text - , nonce :: Maybe Text - , tts :: Maybe Bool - , file :: Maybe (Text, ByteString) - , embed :: Maybe Embed - , allowedMentions :: Maybe AllowedMentions - } - deriving ( Show, Generic, Default ) - -data AllowedMentionType - = AllowedMentionRoles - | AllowedMentionUsers - | AllowedMentionEveryone - deriving ( Show, Generic ) - -instance ToJSON AllowedMentionType where - toJSON AllowedMentionRoles = String "roles" - toJSON AllowedMentionUsers = String "users" - toJSON AllowedMentionEveryone = String "everyone" - -data AllowedMentions = AllowedMentions - { parse :: [AllowedMentionType] - , roles :: [Snowflake Role] - , users :: [Snowflake User] - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON AllowedMentions - -instance Semigroup AllowedMentions where - AllowedMentions p0 r0 u0 <> AllowedMentions p1 r1 u1 = - AllowedMentions (p0 <> p1) (r0 <> r1) (u0 <> u1) - -instance Monoid AllowedMentions where - mempty = def - -data CreateMessageJson = CreateMessageJson - { content :: Maybe Text - , nonce :: Maybe Text - , tts :: Maybe Bool - , embed :: Maybe Embed - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON CreateMessageJson - -data ChannelUpdate = ChannelUpdate - { name :: Maybe Text - , position :: Maybe Int - , topic :: Maybe Text - , nsfw :: Maybe Bool - , rateLimitPerUser :: Maybe Int - , bitrate :: Maybe Int - , userLimit :: Maybe Int - , permissionOverwrites :: Maybe [Overwrite] - , parentID :: Maybe (Snowflake Channel) - } - deriving ( Generic, Show, Default ) - deriving ( ToJSON ) via CalamityJSON ChannelUpdate - -data ChannelMessagesQuery - = ChannelMessagesAround - { around :: Snowflake Message - } - | ChannelMessagesBefore - { before :: Snowflake Message - } - | ChannelMessagesAfter - { after :: Snowflake Message - } - | ChannelMessagesLimit - { limit :: Int - } - deriving ( Generic, Show ) - deriving ( ToJSON ) via CalamityJSON ChannelMessagesQuery - -data GetReactionsOptions = GetReactionsOptions - { before :: Maybe (Snowflake User) - , after :: Maybe (Snowflake User) - , limit :: Maybe Integer - } - deriving ( Show, Generic, Default ) - -data CreateChannelInviteOptions = CreateChannelInviteOptions - { maxAge :: Maybe Int - , maxUses :: Maybe Int - , temporary :: Maybe Bool - , unique :: Maybe Bool - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON CreateChannelInviteOptions - -data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions - { accessToken :: Text - , nick :: Text - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON GroupDMAddRecipientOptions - -data ChannelRequest a where - CreateMessage :: (HasID Channel c) => c -> CreateMessageOptions -> ChannelRequest Message - GetMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message - EditMessage :: (HasID Channel c, HasID Message m) => c -> m -> Maybe Text -> Maybe Embed -> ChannelRequest Message - DeleteMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - BulkDeleteMessages :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest () - GetChannel :: (HasID Channel c) => c -> ChannelRequest Channel - ModifyChannel :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel - DeleteChannel :: (HasID Channel c) => c -> ChannelRequest () - GetChannelMessages :: (HasID Channel c) => c -> Maybe ChannelMessagesQuery -> ChannelRequest [Message] - CreateReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () - DeleteOwnReaction :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest () - DeleteUserReaction :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest () - GetReactions :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User] - DeleteAllReactions :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - GetChannelInvites :: (HasID Channel c) => c -> ChannelRequest [Invite] - CreateChannelInvite :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite - EditChannelPermissions :: (HasID Channel c) => c -> Overwrite -> ChannelRequest () - DeleteChannelPermission :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest () - TriggerTyping :: (HasID Channel c) => c -> ChannelRequest () - GetPinnedMessages :: (HasID Channel c) => c -> ChannelRequest [Message] - AddPinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - DeletePinnedMessage :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest () - GroupDMAddRecipient :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest () - GroupDMRemoveRecipient :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest () - - -baseRoute :: Snowflake Channel -> RouteBuilder _ -baseRoute id = mkRouteBuilder // S "channels" // ID @Channel - & giveID id - -encodeEmoji :: RawEmoji -> S.Text -encodeEmoji = S.decodeUtf8 . urlEncode True . S.encodeUtf8 . showt - -instance Request (ChannelRequest a) where - type Result (ChannelRequest a) = a - - route (CreateMessage (getID -> id) _) = baseRoute id // S "messages" - & buildRoute - route (GetChannel (getID -> id)) = baseRoute id - & buildRoute - route (ModifyChannel (getID -> id) _) = baseRoute id - & buildRoute - route (DeleteChannel (getID -> id)) = baseRoute id - & buildRoute - route (GetChannelMessages (getID -> id) _) = baseRoute id // S "messages" - & buildRoute - route (GetMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute - route (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // S "@me" - & giveID mid - & buildRoute - route (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // S "@me" - & giveID mid - & buildRoute - route (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) // ID @User - & giveID mid - & giveID uid - & buildRoute - route (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) = - baseRoute cid // S "messages" // ID @Message // S "reactions" // S (encodeEmoji emoji) - & giveID mid - & buildRoute - route (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) = - baseRoute cid // S "messages" // ID @Message // S "reactions" - & giveID mid - & buildRoute - route (EditMessage (getID -> cid) (getID @Message -> mid) _ _) = baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute - route (DeleteMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message - & giveID mid - & buildRoute - route (BulkDeleteMessages (getID -> cid) _) = baseRoute cid // S "messages" // S "bulk-delete" - & buildRoute - route (GetChannelInvites (getID -> cid)) = baseRoute cid // S "invites" - & buildRoute - route (CreateChannelInvite (getID -> cid) _) = baseRoute cid // S "invites" - & buildRoute - route (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) = - baseRoute cid // S "permissions" // ID @Overwrite - & giveID oid - & buildRoute - route (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) = - baseRoute cid // S "permissions" // ID @Overwrite - & giveID oid - & buildRoute - route (TriggerTyping (getID -> cid)) = baseRoute cid // S "typing" - & buildRoute - route (GetPinnedMessages (getID -> cid)) = baseRoute cid // S "pins" - & buildRoute - route (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message - & giveID mid - & buildRoute - route (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message - & giveID mid - & buildRoute - route (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = baseRoute cid // S "recipients" // ID @User - & giveID uid - & buildRoute - route (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = baseRoute cid // S "recipients" // ID @User - & giveID uid - & buildRoute - - action (CreateMessage _ o@CreateMessageOptions { file = Nothing }) = postWith' - (toJSON . upcast @CreateMessageJson $ o) - action (CreateMessage _ o@CreateMessageOptions { file = Just f }) = postWith' - [partLBS @IO "file" (snd f) & partFileName ?~ (S.unpack $ fst f) & partContentType ?~ defaultMimeLookup (fst f), - partLBS "payload_json" (encode . upcast @CreateMessageJson $ o)] - action (GetChannel _) = getWith - action (ModifyChannel _ p) = putWith' (toJSON p) - action (DeleteChannel _) = deleteWith - action (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a)))) = getWithP - (param "around" .~ [a]) - action (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a)))) = getWithP - (param "before" .~ [a]) - action (GetChannelMessages _ (Just (ChannelMessagesAfter (showt . fromSnowflake -> a)))) = getWithP - (param "after" .~ [a]) - action (GetChannelMessages _ (Just (ChannelMessagesLimit (showt -> a)))) = getWithP (param "around" .~ [a]) - action (GetChannelMessages _ Nothing) = getWith - action (GetMessage _ _) = getWith - action CreateReaction {} = putEmpty - action DeleteOwnReaction {} = deleteWith - action DeleteUserReaction {} = deleteWith - action (GetReactions _ _ _ GetReactionsOptions { before, after, limit }) = getWithP - (param "before" .~ maybeToList (showt <$> before) >>> - param "after" .~ maybeToList (showt <$> after) >>> - param "limit" .~ maybeToList (showt <$> limit)) - action (DeleteAllReactions _ _) = deleteWith - action (EditMessage _ _ content embed) = patchWith' (object ["content" .= content, "embed" .= embed]) - action (DeleteMessage _ _) = deleteWith - action (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (object ["messages" .= ids]) - action (GetChannelInvites _) = getWith - action (CreateChannelInvite _ o) = postWith' (toJSON o) - action (EditChannelPermissions _ o) = putWith' (toJSON o) - action (DeleteChannelPermission _ _) = deleteWith - action (TriggerTyping _) = postEmpty - action (GetPinnedMessages _) = getWith - action (AddPinnedMessage _ _) = putEmpty - action (DeletePinnedMessage _ _) = deleteWith - action (GroupDMAddRecipient _ _ o) = putWith' (toJSON o) - action (GroupDMRemoveRecipient _ _) = deleteWith diff --git a/src/Calamity/HTTP/Emoji.hs b/src/Calamity/HTTP/Emoji.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Emoji.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | Emoji endpoints -module Calamity.HTTP.Emoji - ( EmojiRequest(..) - , CreateGuildEmojiOptions(..) - , ModifyGuildEmojiOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Function -import Data.Text ( Text ) - -import GHC.Generics - -import Network.Wreq.Session - - -data CreateGuildEmojiOptions = CreateGuildEmojiOptions - { name :: Text - , image :: Text - , roles :: [Snowflake Role] - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON CreateGuildEmojiOptions - -data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions - { name :: Text - , roles :: [Snowflake Role] - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildEmojiOptions - -data EmojiRequest a where - ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji] - GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji - CreateGuildEmoji :: (HasID Guild g) => g -> CreateGuildEmojiOptions -> EmojiRequest Emoji - ModifyGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> ModifyGuildEmojiOptions -> EmojiRequest Emoji - DeleteGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest () - -baseRoute :: Snowflake Guild -> RouteBuilder _ -baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild // S "emojis" & giveID id - -instance Request (EmojiRequest a) where - type Result (EmojiRequest a) = a - - route (ListGuildEmojis (getID -> gid)) = baseRoute gid & buildRoute - route (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji - & giveID eid - & buildRoute - route (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute - route (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = baseRoute gid // ID @Emoji - & giveID eid - & buildRoute - route (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji - & giveID eid - & buildRoute - - action (ListGuildEmojis _) = getWith - action (GetGuildEmoji _ _) = getWith - action (CreateGuildEmoji _ o) = postWith' (toJSON o) - action (ModifyGuildEmoji _ _ o) = patchWith' (toJSON o) - action (DeleteGuildEmoji _ _) = deleteWith diff --git a/src/Calamity/HTTP/Guild.hs b/src/Calamity/HTTP/Guild.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Guild.hs +++ /dev/null @@ -1,282 +0,0 @@ --- | Guild endpoints -module Calamity.HTTP.Guild - ( GuildRequest(..) - , CreateGuildData(..) - , ModifyGuildData(..) - , ChannelCreateData(..) - , ChannelPosition(..) - , ListMembersOptions(..) - , AddGuildMemberData(..) - , ModifyGuildMemberData(..) - , CreateGuildBanData(..) - , ModifyGuildRoleData(..) - , ModifyGuildRolePositionsData(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Internal.IntColour () -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Model.Voice -import Calamity.Types.Snowflake - -import Control.Arrow -import Control.Lens hiding ( (.=) ) - -import Data.Aeson -import Data.Colour ( Colour ) -import Data.Default.Class -import Data.Maybe -import Data.Text ( Text ) - -import GHC.Generics - -import Network.Wreq.Lens -import Network.Wreq.Session - -import TextShow - -data CreateGuildData = CreateGuildData - { name :: Text - , region :: Text - , icon :: Text - , verificationLevel :: Integer -- TODO: enums for these - , defaultMessageNotifications :: Integer - , explicitContentFilter :: Integer - , roles :: [Role] - , channels :: [Partial Channel] - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON CreateGuildData - -data ModifyGuildData = ModifyGuildData - { name :: Maybe Text - , region :: Maybe Text - , icon :: Maybe Text - , verificationLevel :: Maybe Integer -- TODO: enums for these - , defaultMessageNotifications :: Maybe Integer - , explicitContentFilter :: Maybe Integer - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Maybe Integer - , ownerID :: Maybe (Snowflake User) - , splash :: Maybe Text - , banner :: Maybe Text - , systemChannelID :: Maybe (Snowflake GuildChannel) - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildData - -data ChannelCreateData = ChannelCreateData - { name :: Text - , type_ :: Maybe ChannelType - , topic :: Maybe Text - , bitrate :: Maybe Integer - , userLimit :: Maybe Integer - , rateLimitPerUser :: Maybe Integer - , position :: Maybe Integer - , permissionOverwrites :: Maybe [Overwrite] - , parentID :: Maybe (Snowflake Category) - , nsfw :: Maybe Bool - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ChannelCreateData - -data ChannelPosition = ChannelPosition - { id :: Snowflake GuildChannel - , position :: Maybe Integer - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ChannelPosition - -data ListMembersOptions = ListMembersOptions - { limit :: Maybe Integer - , after :: Maybe (Snowflake User) - } - deriving ( Show, Generic, Default ) - -data AddGuildMemberData = AddGuildMemberData - { accessToken :: Text - , nick :: Maybe Text - , roles :: Maybe [Snowflake Role] - , mute :: Maybe Bool - , deaf :: Maybe Bool - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON AddGuildMemberData - -data ModifyGuildMemberData = ModifyGuildMemberData - { nick :: Maybe Text - , roles :: Maybe [Snowflake Role] - , mute :: Maybe Bool - , deaf :: Maybe Bool - , channelID :: Maybe (Snowflake VoiceChannel) - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildMemberData - -data CreateGuildBanData = CreateGuildBanData - { deleteMessageDays :: Maybe Integer - , reason :: Maybe Text - } - deriving ( Show, Generic, Default ) - -data ModifyGuildRoleData = ModifyGuildRoleData - { name :: Maybe Text - , permissions :: Maybe Permissions - , color :: Maybe (Colour Double) - , hoist :: Maybe Bool - , mentionable :: Maybe Bool - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildRoleData - -data ModifyGuildRolePositionsData = ModifyGuildRolePositionsData - { id :: Snowflake Role - , position :: Maybe Integer - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ModifyGuildRolePositionsData - -data GuildRequest a where - CreateGuild :: CreateGuildData -> GuildRequest Guild - GetGuild :: HasID Guild g => g -> GuildRequest Guild - ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild - DeleteGuild :: HasID Guild g => g -> GuildRequest () - GetGuildChannels :: HasID Guild g => g -> GuildRequest [Channel] - CreateGuildChannel :: HasID Guild g => g -> ChannelCreateData -> GuildRequest Channel - ModifyGuildChannelPositions :: HasID Guild g => g -> [ChannelPosition] -> GuildRequest () - GetGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest Member - ListGuildMembers :: HasID Guild g => g -> ListMembersOptions -> GuildRequest [Member] - AddGuildMember :: (HasID Guild g, HasID User u) => g -> u -> AddGuildMemberData -> GuildRequest (Maybe Member) - ModifyGuildMember :: (HasID Guild g, HasID User u) => g -> u -> ModifyGuildMemberData -> GuildRequest () - ModifyCurrentUserNick :: HasID Guild g => g -> Maybe Text -> GuildRequest () - AddGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () - RemoveGuildMemberRole :: (HasID Guild g, HasID User u, HasID Role r) => g -> u -> r -> GuildRequest () - RemoveGuildMember :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () - GetGuildBans :: HasID Guild g => g -> GuildRequest [BanData] - GetGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest BanData - CreateGuildBan :: (HasID Guild g, HasID User u) => g -> u -> CreateGuildBanData -> GuildRequest () - RemoveGuildBan :: (HasID Guild g, HasID User u) => g -> u -> GuildRequest () - GetGuildRoles :: HasID Guild g => g -> GuildRequest [Role] - CreateGuildRole :: HasID Guild g => g -> ModifyGuildRoleData -> GuildRequest Role - ModifyGuildRolePositions :: HasID Guild g => g -> ModifyGuildRolePositionsData -> GuildRequest [Role] - ModifyGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> ModifyGuildRoleData -> GuildRequest Role - DeleteGuildRole :: (HasID Guild g, HasID Role r) => g -> r -> GuildRequest () - GetGuildPruneCount :: HasID Guild g => g -> Integer -> GuildRequest Integer - BeginGuildPrune :: HasID Guild g => g -> Integer -> Bool -> GuildRequest (Maybe Integer) - GetGuildVoiceRegions :: HasID Guild g => g -> GuildRequest [VoiceRegion] - GetGuildInvites :: HasID Guild g => g -> GuildRequest [Invite] - -baseRoute :: Snowflake Guild -> RouteBuilder _ -baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild - & giveID id - -instance Request (GuildRequest a) where - type Result (GuildRequest a) = a - - route (CreateGuild _) = mkRouteBuilder // S "guilds" - & buildRoute - route (GetGuild (getID -> gid)) = baseRoute gid - & buildRoute - route (ModifyGuild (getID -> gid) _) = baseRoute gid - & buildRoute - route (DeleteGuild (getID -> gid)) = baseRoute gid - & buildRoute - route (GetGuildChannels (getID -> gid)) = baseRoute gid // S "channels" - & buildRoute - route (CreateGuildChannel (getID -> gid) _) = baseRoute gid // S "channels" - & buildRoute - route (ModifyGuildChannelPositions (getID -> gid) _) = baseRoute gid // S "channels" - & buildRoute - route (GetGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (ListGuildMembers (getID -> gid) _) = baseRoute gid // S "members" - & buildRoute - route (AddGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (ModifyGuildMember (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (ModifyCurrentUserNick (getID -> gid) _) = baseRoute gid // S "members" // S "@me" // S "nick" - & buildRoute - route (AddGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = - baseRoute gid // S "members" // ID @User // S "roles" // ID @Role - & giveID uid - & giveID rid - & buildRoute - route (RemoveGuildMemberRole (getID -> gid) (getID @User -> uid) (getID @Role -> rid)) = - baseRoute gid // S "members" // ID @User // S "roles" // ID @Role - & giveID uid - & giveID rid - & buildRoute - route (RemoveGuildMember (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "members" // ID @User - & giveID uid - & buildRoute - route (GetGuildBans (getID -> gid)) = baseRoute gid // S "bans" - & buildRoute - route (GetGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute - route (CreateGuildBan (getID -> gid) (getID @User -> uid) _) = baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute - route (RemoveGuildBan (getID -> gid) (getID @User -> uid)) = baseRoute gid // S "bans" // ID @User - & giveID uid - & buildRoute - route (GetGuildRoles (getID -> gid)) = baseRoute gid // S "roles" - & buildRoute - route (CreateGuildRole (getID -> gid) _) = baseRoute gid // S "roles" - & buildRoute - route (ModifyGuildRolePositions (getID -> gid) _) = baseRoute gid // S "roles" - & buildRoute - route (ModifyGuildRole (getID -> gid) (getID @Role -> rid) _) = baseRoute gid // S "roles" // ID @Role - & giveID rid - & buildRoute - route (DeleteGuildRole (getID -> gid) (getID @Role -> rid)) = baseRoute gid // S "roles" // ID @Role - & giveID rid - & buildRoute - route (GetGuildPruneCount (getID -> gid) _) = baseRoute gid // S "prune" - & buildRoute - route (BeginGuildPrune (getID -> gid) _ _) = baseRoute gid // S "prune" - & buildRoute - route (GetGuildVoiceRegions (getID -> gid)) = baseRoute gid // S "regions" - & buildRoute - route (GetGuildInvites (getID -> gid)) = baseRoute gid // S "invites" - & buildRoute - - action (CreateGuild o) = postWith' (toJSON o) - action (GetGuild _) = getWith - action (ModifyGuild _ o) = patchWith' (toJSON o) - action (DeleteGuild _) = deleteWith - action (GetGuildChannels _) = getWith - action (CreateGuildChannel _ o) = postWith' (toJSON o) - action (ModifyGuildChannelPositions _ o) = postWith' (toJSON o) - action (GetGuildMember _ _) = getWith - action (ListGuildMembers _ ListMembersOptions { limit, after }) = getWithP - (param "limit" .~ maybeToList (showt <$> limit) >>> param "after" .~ maybeToList (showt <$> after)) - action (AddGuildMember _ _ o) = putWith' (toJSON o) - action (ModifyGuildMember _ _ o) = patchWith' (toJSON o) - action (ModifyCurrentUserNick _ nick) = patchWith' (object ["nick" .= nick]) - action (AddGuildMemberRole {}) = putEmpty - action (RemoveGuildMemberRole {}) = deleteWith - action (RemoveGuildMember _ _) = deleteWith - action (GetGuildBans _) = getWith - action (GetGuildBan _ _) = getWith - action (CreateGuildBan _ _ CreateGuildBanData { deleteMessageDays, reason }) = putEmptyP - (param "delete-message-days" .~ maybeToList (showt <$> deleteMessageDays) >>> param "reason" .~ maybeToList - (showt <$> reason)) - action (RemoveGuildBan _ _) = deleteWith - action (GetGuildRoles _) = getWith - action (CreateGuildRole _ o) = postWith' (toJSON o) - action (ModifyGuildRolePositions _ o) = patchWith' (toJSON o) - action (ModifyGuildRole _ _ o) = patchWith' (toJSON o) - action (DeleteGuildRole _ _) = deleteWith - action (GetGuildPruneCount _ d) = getWithP (param "days" .~ [showt d]) - action (BeginGuildPrune _ d r) = postEmptyP (param "days" .~ [showt d] >>> param "compute_prune_count" .~ [showt r]) - action (GetGuildVoiceRegions _) = getWith - action (GetGuildInvites _) = getWith diff --git a/src/Calamity/HTTP/Internal/Ratelimit.hs b/src/Calamity/HTTP/Internal/Ratelimit.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Internal/Ratelimit.hs +++ /dev/null @@ -1,202 +0,0 @@ --- | Module containing ratelimit stuff -module Calamity.HTTP.Internal.Ratelimit - ( newRateLimitState - , doRequest ) where - -import Calamity.Client.Types ( BotC ) -import Calamity.HTTP.Internal.Route -import Calamity.HTTP.Internal.Types -import Calamity.Internal.Utils - -import Control.Concurrent -import Control.Concurrent.Event ( Event ) -import qualified Control.Concurrent.Event as E -import Control.Concurrent.STM -import Control.Concurrent.STM.Lock ( Lock ) -import qualified Control.Concurrent.STM.Lock as L -import Control.Lens -import Control.Monad - -import Data.Aeson -import Data.Aeson.Lens -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as LB -import Data.Functor -import Data.Maybe -import qualified Data.Text.Lazy as LT -import Data.Time -import Data.Time.Clock.POSIX - -import Fmt - -import Focus - -import Network.HTTP.Date -import Network.HTTP.Types hiding ( statusCode ) -import Network.Wreq - -import qualified Polysemy as P -import Polysemy ( Sem ) -import qualified Polysemy.Async as P - -import Prelude hiding ( error ) - -import qualified StmContainers.Map as SC -import qualified Control.Exception.Safe as Ex - -newRateLimitState :: IO RateLimitState -newRateLimitState = RateLimitState <$> SC.newIO <*> E.newSet - -lookupOrInsertDefaultM :: Monad m => m a -> Focus a m a -lookupOrInsertDefaultM aM = casesM - (do a <- aM - pure (a, Set a)) - (\a -> pure (a, Leave)) - -getRateLimit :: RateLimitState -> Route -> STM Lock -getRateLimit s h = SC.focus (lookupOrInsertDefaultM L.new) h (rateLimits s) - -doDiscordRequest :: BotC r => IO (Response LB.ByteString) -> Sem r DiscordResponseType -doDiscordRequest r = do - r'' <- P.embed $ Ex.catchAny (Right <$> r) (pure . Left . Ex.displayException) - case r'' of - Right r' -> do - let status = r' ^. responseStatus - if - | statusIsSuccessful status -> do - let resp = r' ^. responseBody - debug $ "Got good response from discord: " +|| r' ^. responseStatus ||+ "" - pure $ if isExhausted r' - then case parseRateLimitHeader r' of - Just sleepTime -> ExhaustedBucket resp sleepTime - Nothing -> ServerError (status ^. statusCode) - else Good resp - | status == status429 -> do - debug "Got 429 from discord, retrying." - case asValue r' of - Just rv -> pure $ Ratelimited (parseRetryAfter rv) (isGlobal rv) - Nothing -> pure $ ClientError (status ^. statusCode) "429 with invalid json???" - | statusIsClientError status -> do - let err = r' ^. responseBody - error $ "Something went wrong: " +|| err ||+ " response: " +|| r' ||+ "" - pure $ ClientError (status ^. statusCode) err - | otherwise -> do - debug $ "Got server error from discord: " +| status ^. statusCode |+ "" - pure $ ServerError (status ^. statusCode) - Left e -> do - error $ "Something went wrong with the http client: " +| LT.pack e |+ "" - pure . InternalResponseError $ LT.pack e - - -parseDiscordTime :: ByteString -> Maybe UTCTime -parseDiscordTime s = httpDateToUTC <$> parseHTTPDate s - -computeDiscordTimeDiff :: Double -> UTCTime -> Int -computeDiscordTimeDiff end now = round . (* 1000.0) $ diffUTCTime end' now - where end' = end & toRational & fromRational & posixSecondsToUTCTime - --- | Parse a ratelimit header returning the number of milliseconds until it resets -parseRateLimitHeader :: Response a -> Maybe Int -parseRateLimitHeader r = computeDiscordTimeDiff end <$> now - where - end = r ^?! responseHeader "X-Ratelimit-Reset" . _Double - now = r ^?! responseHeader "Date" & parseDiscordTime - -isExhausted :: Response a -> Bool -isExhausted r = r ^? responseHeader "X-RateLimit-Remaining" == Just "0" - -parseRetryAfter :: Response Value -> Int -parseRetryAfter r = - r ^?! responseBody . key "retry_after" . _Integral - -isGlobal :: Response Value -> Bool -isGlobal r = r ^? responseBody . key "global" . _Bool == Just True - - --- Either (Either a a) b -data ShouldRetry a b - = Retry a - | RFail a - | RGood b - -retryRequest - :: BotC r - => Int -- ^ number of retries - -> Sem r (ShouldRetry a b) -- ^ action to perform - -> Sem r () -- ^ action to run if max number of retries was reached - -> Sem r (Either a b) -retryRequest max_retries action failAction = retryInner 0 - where - retryInner num_retries = do - res <- action - case res of - Retry r | num_retries > max_retries -> do - debug $ "Request failed after " +| max_retries |+ " retries." - doFail $ Left r - Retry _ -> retryInner (num_retries + 1) - RFail r -> do - debug "Request failed due to error response." - doFail $ Left r - RGood r -> pure $ Right r - where doFail v = failAction $> v - - --- Run a single request --- NOTE: this function will only unlock the ratelimit lock if the request --- gave a response, otherwise it will stay locked so that it can be retried again -doSingleRequest - :: BotC r - => Event -- ^ Global lock - -> Lock -- ^ Local lock - -> IO (Response LB.ByteString) -- ^ Request action - -> Sem r (ShouldRetry RestError LB.ByteString) -doSingleRequest gl l r = do - r' <- doDiscordRequest r - case r' of - Good v -> do - P.embed . atomically $ L.release l - pure $ RGood v - - ExhaustedBucket v d -> do - debug $ "Exhausted bucket, unlocking after " +| d |+ "ms" - void . P.async $ do - P.embed $ do - threadDelay $ 1000 * d - atomically $ L.release l - debug "unlocking bucket" - pure $ RGood v - - Ratelimited d False -> do - debug $ "429 ratelimited on route, sleeping for " +| d |+ " ms" - P.embed . threadDelay $ 1000 * d - pure $ Retry (HTTPError 429 Nothing) - - Ratelimited d True -> do - debug "429 ratelimited globally" - P.embed $ do - E.clear gl - threadDelay $ 1000 * d - E.set gl - pure $ Retry (HTTPError 429 Nothing) - - ServerError c -> do - debug "Server failed, retrying" - pure $ Retry (HTTPError c Nothing) - - InternalResponseError c -> do - debug "Internal error, retrying" - pure $ Retry (InternalClientError c) - - ClientError c v -> pure $ RFail (HTTPError c $ decode v) - -doRequest :: BotC r => RateLimitState -> Route -> IO (Response LB.ByteString) -> Sem r (Either RestError LB.ByteString) -doRequest rlState route action = do - P.embed $ E.wait (globalLock rlState) - - ratelimit <- P.embed . atomically $ do - lock <- getRateLimit rlState route - L.acquire lock - pure lock - - retryRequest 5 (doSingleRequest (globalLock rlState) ratelimit action) - (P.embed . atomically $ L.release ratelimit) diff --git a/src/Calamity/HTTP/Internal/Request.hs b/src/Calamity/HTTP/Internal/Request.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Internal/Request.hs +++ /dev/null @@ -1,125 +0,0 @@ --- | Generic Request type -module Calamity.HTTP.Internal.Request - ( Request(..) - , postWith' - , postWithP' - , putWith' - , patchWith' - , putEmpty - , putEmptyP - , postEmpty - , postEmptyP - , getWithP ) where - -import Calamity.Client.Types -import Calamity.HTTP.Internal.Ratelimit -import Calamity.HTTP.Internal.Route -import Calamity.HTTP.Internal.Types -import Calamity.Metrics.Eff -import Calamity.Types.Token - -import Control.Lens -import Control.Monad - -import Data.Aeson hiding ( Options ) -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as LB -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy as TL -import Data.Text.Strict.Lens - -import DiPolysemy hiding ( debug, error, info ) - -import Network.Wreq (Response, checkResponse, header, defaults) -import Network.Wreq.Session -import Network.Wreq.Types (Options, Postable, Putable ) - -import Polysemy ( Sem ) -import qualified Polysemy as P -import qualified Polysemy.Error as P -import qualified Polysemy.Reader as P - -fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a -fromResult (Success a) = pure a -fromResult (Error e) = P.throw (InternalClientError . TL.pack $ e) - -fromJSONDecode :: P.Member (P.Error RestError) r => Either String a -> Sem r a -fromJSONDecode (Right a) = pure a -fromJSONDecode (Left e) = P.throw (InternalClientError . TL.pack $ e) - -extractRight :: P.Member (P.Error e) r => Either e a -> Sem r a -extractRight (Left e) = P.throw e -extractRight (Right a) = pure a - -class ReadResponse a where - readResp :: LB.ByteString -> Either String a - -instance ReadResponse () where - readResp = const (Right ()) - -instance {-# OVERLAPS #-}FromJSON a => ReadResponse a where - readResp = eitherDecode - -class Request a where - type Result a - - route :: a -> Route - - action :: a -> Options -> Session -> String -> IO (Response LB.ByteString) - - invoke :: (BotC r, FromJSON (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a)) - invoke a = do - rlState' <- P.asks (^. #rlState) - session <- P.asks (^. #session) - token' <- P.asks (^. #token) - - let route' = route a - - inFlightRequests <- registerGauge "inflight_requests" [("route", route' ^. #path)] - totalRequests <- registerCounter "total_requests" [("route", route' ^. #path)] - void $ modifyGauge (+ 1) inFlightRequests - void $ addCounter 1 totalRequests - - resp <- attr "route" (route' ^. #path) $ doRequest rlState' route' - (action a (requestOptions token') session (route' ^. #path . unpacked)) - - void $ modifyGauge (subtract 1) inFlightRequests - - P.runError $ (fromResult . fromJSON) =<< (fromJSONDecode . readResp) =<< extractRight resp - -defaultRequestOptions :: Options -defaultRequestOptions = defaults - & header "User-Agent" .~ ["Calamity (https://github.com/nitros12/calamity)"] - & header "X-RateLimit-Precision" .~ ["millisecond"] - & checkResponse ?~ (\_ _ -> pure ()) - -requestOptions :: Token -> Options -requestOptions t = defaultRequestOptions - & header "Authorization" .~ [TS.encodeUtf8 . TL.toStrict $ formatToken t] - -postWith' :: Postable a => a -> Options -> Session -> String -> IO (Response LB.ByteString) -postWith' p o sess s = postWith o sess s p - -postWithP' :: Postable a => a -> (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -postWithP' p oF o sess s = postWith (oF o) sess s p - -postEmpty :: Options -> Session -> String -> IO (Response LB.ByteString) -postEmpty o sess s = postWith o sess s ("" :: ByteString) - -putWith' :: Putable a => a -> Options -> Session -> String -> IO (Response LB.ByteString) -putWith' p o sess s = putWith o sess s p - -patchWith' :: Postable a => a -> Options -> Session -> String -> IO (Response LB.ByteString) -patchWith' p o sess s = customPayloadMethodWith "PATCH" o sess s p - -putEmpty :: Options -> Session -> String -> IO (Response LB.ByteString) -putEmpty o sess s = putWith o sess s ("" :: ByteString) - -putEmptyP :: (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -putEmptyP = (putEmpty .) - -postEmptyP :: (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -postEmptyP = (postEmpty .) - -getWithP :: (Options -> Options) -> Options -> Session -> String -> IO (Response LB.ByteString) -getWithP oF o = getWith (oF o) diff --git a/src/Calamity/HTTP/Internal/Route.hs b/src/Calamity/HTTP/Internal/Route.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Internal/Route.hs +++ /dev/null @@ -1,145 +0,0 @@ --- | The route type --- Why I did this I don't know -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module Calamity.HTTP.Internal.Route - ( mkRouteBuilder - , giveID - , buildRoute - , RouteBuilder - , RouteRequirement - , Route(path) - , S(..) - , ID(..) - , RouteFragmentable(..) ) where - -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Snowflake - -import Data.Hashable -import Data.Kind -import Data.Maybe ( fromJust ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Data.Typeable -import Data.Word - -import GHC.Generics hiding ( S ) - -import TextShow - -data RouteFragment - = S' Text - | ID' TypeRep - deriving ( Generic, Show, Eq ) - -newtype S = S Text - -data ID a = ID - -instance Hashable RouteFragment - -data RouteRequirement - = NotNeeded - | Required - | Satisfied - deriving ( Generic, Show, Eq ) - -data RouteBuilder (idState :: [(Type, RouteRequirement)]) = UnsafeMkRouteBuilder - { route :: [RouteFragment] - , ids :: [(TypeRep, Word64)] - } - -mkRouteBuilder :: RouteBuilder '[] -mkRouteBuilder = UnsafeMkRouteBuilder [] [] - -giveID - :: forall k ids - . Typeable k - => Snowflake k - -> RouteBuilder ids - -> RouteBuilder ('(k, 'Satisfied) ': ids) -giveID (Snowflake id) (UnsafeMkRouteBuilder route ids) = - UnsafeMkRouteBuilder route ((typeRep (Proxy @k), id) : ids) - -type family (&&) (a :: Bool) (b :: Bool) :: Bool where - 'True && 'True = 'True - _ && _ = 'False - -type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where - Lookup k ('(k, v) ': xs) = 'Just v - Lookup k ('(_, v) ': xs) = Lookup k xs - Lookup _ '[] = 'Nothing - -type family IsElem (x :: k) (l :: [k]) :: Bool where - IsElem _ '[] = 'False - IsElem k (k : _) = 'True - IsElem k (_ : xs) = IsElem k xs - -type family EnsureFulfilled (ids :: [(k, RouteRequirement)]) :: Constraint where - EnsureFulfilled ids = EnsureFulfilledInner ids '[] 'True - -type family EnsureFulfilledInner (ids :: [(k, RouteRequirement)]) (seen :: [k]) (ok :: Bool) :: Constraint where - EnsureFulfilledInner '[] _ 'True = () - EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok - EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok - EnsureFulfilledInner ('(k, 'Required) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok) - -type family AddRequired k (ids :: [(Type, RouteRequirement)]) :: [(Type, RouteRequirement)] where - AddRequired k ids = '(k, AddRequiredInner (Lookup k ids)) ': ids - -type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where - AddRequiredInner ('Just 'Required) = 'Required - AddRequiredInner ('Just 'Satisfied) = 'Satisfied - AddRequiredInner ('Just 'NotNeeded) = 'Required - AddRequiredInner 'Nothing = 'Required - -class Typeable a => RouteFragmentable a ids where - type ConsRes a ids - - (//) :: RouteBuilder ids -> a -> ConsRes a ids - -instance RouteFragmentable S ids where - type ConsRes S ids = RouteBuilder ids - - (UnsafeMkRouteBuilder r ids) // (S t) = - UnsafeMkRouteBuilder (r <> [S' t]) ids - -instance Typeable a => RouteFragmentable (ID (a :: Type)) (ids :: [(Type, RouteRequirement)]) where - type ConsRes (ID a) ids = RouteBuilder (AddRequired a ids) - - (UnsafeMkRouteBuilder r ids) // ID = - UnsafeMkRouteBuilder (r <> [ID' (typeRep (Proxy @a))]) ids - -infixl 5 // - -data Route = Route - { path :: Text - , key :: Text - , channelID :: Maybe (Snowflake Channel) - , guildID :: Maybe (Snowflake Guild) - } deriving (Generic, Show, Eq) - -instance Hashable Route where - hashWithSalt s (Route _ ident c g) = hashWithSalt s (ident, c, g) - -baseURL :: Text -baseURL = "https://discord.com/api/v7" - -buildRoute - :: forall (ids :: [(Type, RouteRequirement)]) - . EnsureFulfilled ids - => RouteBuilder ids - -> Route -buildRoute (UnsafeMkRouteBuilder route ids) = Route - (T.intercalate "/" (baseURL : map goR route)) - (T.concat (map goIdent route)) - (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids) - (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids) - where - goR (S' t) = t - goR (ID' t) = showt . fromJust $ lookup t ids - - goIdent (S' t) = t - goIdent (ID' t) = showt t diff --git a/src/Calamity/HTTP/Internal/Types.hs b/src/Calamity/HTTP/Internal/Types.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Internal/Types.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | Types for the http lib -module Calamity.HTTP.Internal.Types - ( RestError(..) - , RateLimitState(..) - , DiscordResponseType(..) - , GatewayResponse - , BotGatewayResponse ) where - -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings - -import Control.Concurrent.Event ( Event ) -import Control.Concurrent.STM.Lock ( Lock ) - -import Data.Aeson -import qualified Data.ByteString.Lazy as LB -import Data.Text.Lazy - -import GHC.Generics - -import qualified StmContainers.Map as SC - -data RestError - -- | An error response from discord - = HTTPError - { status :: Int - , response :: Maybe Value - } - -- | Something failed while making the request (after retrying a few times) - | InternalClientError Text - deriving ( Show, Generic ) - -data RateLimitState = RateLimitState - { rateLimits :: SC.Map Route Lock - , globalLock :: Event - } - deriving ( Generic ) - -data DiscordResponseType - = Good LB.ByteString -- ^ A good response - | ExhaustedBucket -- ^ We got a response but also exhausted the bucket - LB.ByteString Int -- ^ Retry after (milliseconds) - | Ratelimited -- ^ We hit a 429, no response and ratelimited - Int -- ^ Retry after (milliseconds) - Bool -- ^ Global ratelimit - | ServerError Int -- ^ Discord's error, we should retry (HTTP 5XX) - | ClientError Int LB.ByteString -- ^ Our error, we should fail - | InternalResponseError Text -- ^ Something went wrong with the http client - -newtype GatewayResponse = GatewayResponse - { url :: Text - } - deriving ( Generic, Show ) - deriving ( FromJSON ) via CalamityJSON GatewayResponse - -data BotGatewayResponse = BotGatewayResponse - { url :: Text - , shards :: Int - } - deriving ( Generic, Show ) - deriving ( FromJSON ) via CalamityJSON BotGatewayResponse diff --git a/src/Calamity/HTTP/Invite.hs b/src/Calamity/HTTP/Invite.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Invite.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Invite endpoints -module Calamity.HTTP.Invite - ( InviteRequest(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Types.Model.Guild - -import Control.Lens hiding ( (.=) ) - -import Data.Text ( Text ) - -import Network.Wreq.Lens -import Network.Wreq.Session - -import TextShow - -data InviteRequest a where - GetInvite :: Text -> InviteRequest Invite - DeleteInvite :: Text -> InviteRequest () - -baseRoute :: RouteBuilder _ -baseRoute = mkRouteBuilder // S "invites" - -instance Request (InviteRequest a) where - type Result (InviteRequest a) = a - - route (GetInvite c) = baseRoute // S c - & buildRoute - route (DeleteInvite c) = baseRoute // S c - & buildRoute - - action (GetInvite _) = getWithP (param "with_counts" .~ [showt True]) - action (DeleteInvite _) = deleteWith diff --git a/src/Calamity/HTTP/MiscRoutes.hs b/src/Calamity/HTTP/MiscRoutes.hs deleted file mode 100644 --- a/src/Calamity/HTTP/MiscRoutes.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Miscellaneous routes -module Calamity.HTTP.MiscRoutes where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.HTTP.Internal.Types - -import Data.Function - -import Network.Wreq.Session - -data MiscRequest a where - GetGateway :: MiscRequest GatewayResponse - GetGatewayBot :: MiscRequest BotGatewayResponse - -instance Request (MiscRequest a) where - type Result (MiscRequest a) = a - - route GetGateway = mkRouteBuilder // S "gateway" - & buildRoute - - route GetGatewayBot = mkRouteBuilder // S "gateway" // S "bot" - & buildRoute - - action GetGateway = getWith - action GetGatewayBot = getWith diff --git a/src/Calamity/HTTP/Reason.hs b/src/Calamity/HTTP/Reason.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Reason.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | A wrapper request that adds a reson to a request -module Calamity.HTTP.Reason - ( Reason(..) - , reason ) where - -import Calamity.HTTP.Internal.Request - -import Control.Lens hiding ( (.=) ) - -import Data.Text ( Text ) -import Data.Text.Encoding ( encodeUtf8 ) - -import GHC.Generics - -import Network.Wreq.Lens - -data Reason a = Reason a Text - deriving ( Show, Eq, Generic ) - --- | Attach a reason to a request -reason :: Request a => Text -> a -> Reason a -reason = flip Reason - -instance Request a => Request (Reason a) where - type Result (Reason a) = Result a - - route (Reason a _) = route a - - action (Reason a r) = action a . (header "X-Audit-Log-Reason" .~ [encodeUtf8 r]) diff --git a/src/Calamity/HTTP/User.hs b/src/Calamity/HTTP/User.hs deleted file mode 100644 --- a/src/Calamity/HTTP/User.hs +++ /dev/null @@ -1,81 +0,0 @@ --- | User endpoints -module Calamity.HTTP.User - ( UserRequest(..) - , ModifyUserData(..) - , GetCurrentUserGuildsOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Control.Arrow -import Control.Lens hiding ( (.=) ) - -import Data.Aeson -import Data.Default.Class -import Data.Maybe -import Data.Text ( Text ) - -import GHC.Generics - -import Network.Wreq.Lens -import Network.Wreq.Session - -import TextShow - -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 - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyUserData - -data GetCurrentUserGuildsOptions = GetCurrentUserGuildsOptions - { before :: Maybe (Snowflake Guild) - , after :: Maybe (Snowflake Guild) - , limit :: Maybe Integer - } - deriving ( Show, Generic, Default ) - -data UserRequest a where - GetCurrentUser :: UserRequest User - GetUser :: HasID User u => u -> UserRequest User - ModifyCurrentUser :: ModifyUserData -> UserRequest User - GetCurrentUserGuilds :: GetCurrentUserGuildsOptions -> UserRequest [Partial Guild] - LeaveGuild :: HasID Guild g => g -> UserRequest () - CreateDM :: HasID User u => u -> UserRequest DMChannel - -baseRoute :: RouteBuilder _ -baseRoute = mkRouteBuilder // S "users" // S "@me" - -instance Request (UserRequest a) where - type Result (UserRequest a) = a - - route GetCurrentUser = baseRoute - & buildRoute - route (GetUser (getID @User -> uid)) = mkRouteBuilder // S "users" // ID @User - & giveID uid - & buildRoute - route (ModifyCurrentUser _) = baseRoute - & buildRoute - route (GetCurrentUserGuilds _) = baseRoute // S "guilds" - & buildRoute - route (LeaveGuild (getID @Guild -> gid)) = baseRoute // S "guilds" // ID @Guild - & giveID gid - & buildRoute - route (CreateDM _) = baseRoute // S "channels" - & buildRoute - - action GetCurrentUser = getWith - action (GetUser _) = getWith - action (ModifyCurrentUser o) = patchWith' (toJSON o) - action (GetCurrentUserGuilds GetCurrentUserGuildsOptions { before, after, limit }) = getWithP - (param "before" .~ maybeToList (showt <$> before) >>> param "after" .~ maybeToList (showt <$> after) >>> param - "limit" .~ maybeToList (showt <$> limit)) - action (LeaveGuild _) = deleteWith - action (CreateDM (getID @User -> uid)) = postWith' (object ["recipient_id" .= uid]) diff --git a/src/Calamity/HTTP/Webhook.hs b/src/Calamity/HTTP/Webhook.hs deleted file mode 100644 --- a/src/Calamity/HTTP/Webhook.hs +++ /dev/null @@ -1,126 +0,0 @@ --- | Webhook endpoints -module Calamity.HTTP.Webhook - ( WebhookRequest(..) - , CreateWebhookData(..) - , ModifyWebhookData(..) - , ExecuteWebhookOptions(..) ) where - -import Calamity.HTTP.Internal.Request -import Calamity.HTTP.Internal.Route -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Snowflake - -import Control.Lens hiding ( (.=) ) - -import Data.Aeson -import Data.ByteString.Lazy ( ByteString ) -import Data.Default.Class -import Data.Generics.Product.Subtype ( upcast ) -import Data.Maybe -import Data.Text ( Text ) - -import GHC.Generics - -import Network.Wreq ( partLBS ) -import Network.Wreq.Lens -import Network.Wreq.Session - -import TextShow - -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 - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON CreateWebhookData - -data ModifyWebhookData = ModifyWebhookData - { username :: Maybe Text - -- | The avatar field should be in discord's image data format: https://discord.com/developers/docs/reference#image-data - , avatar :: Maybe Text - , channelID :: Maybe (Snowflake Channel) - } - deriving ( Show, Generic, Default ) - deriving ( ToJSON ) via CalamityJSON ModifyWebhookData - -data ExecuteWebhookOptions = ExecuteWebhookOptions - { wait :: Maybe Bool - , content :: Maybe Text - , file :: Maybe ByteString - , embeds :: Maybe [Embed] - , username :: Maybe Text - , avatarUrl :: Maybe Text - , tts :: Maybe Bool - } - deriving ( Show, Generic, Default ) - -data ExecuteWebhookJson = ExecuteWebhookJson - { content :: Maybe Text - , embeds :: Maybe [Embed] - , username :: Maybe Text - , avatarUrl :: Maybe Text - , tts :: Maybe Bool - } - deriving ( Show, Generic ) - deriving ( ToJSON ) via CalamityJSON ExecuteWebhookJson - -data WebhookRequest a where - CreateWebhook :: HasID Channel c => c -> CreateWebhookData -> WebhookRequest Webhook - GetChannelWebhooks :: HasID Channel c => c -> WebhookRequest [Webhook] - GetGuildWebhooks :: HasID Guild c => c -> WebhookRequest [Webhook] - GetWebhook :: HasID Webhook w => w -> WebhookRequest Webhook - GetWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest Webhook - ModifyWebhook :: HasID Webhook w => w -> ModifyWebhookData -> WebhookRequest Webhook - ModifyWebhookToken :: HasID Webhook w => w -> Text -> ModifyWebhookData -> WebhookRequest Webhook - DeleteWebhook :: HasID Webhook w => w -> WebhookRequest () - DeleteWebhookToken :: HasID Webhook w => w -> Text -> WebhookRequest () - ExecuteWebhook :: HasID Webhook w => w -> Text -> ExecuteWebhookOptions -> WebhookRequest () - - -baseRoute :: Snowflake Webhook -> RouteBuilder _ -baseRoute id = mkRouteBuilder // S "webhooks" // ID @Webhook & giveID id - -instance Request (WebhookRequest a) where - type Result (WebhookRequest a) = a - - route (CreateWebhook (getID @Channel -> cid) _) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" - & giveID cid - & buildRoute - route (GetChannelWebhooks (getID @Channel -> cid)) = mkRouteBuilder // S "channels" // ID @Channel // S "webhooks" - & giveID cid - & buildRoute - route (GetGuildWebhooks (getID @Guild -> gid)) = mkRouteBuilder // S "guilds" // ID @Guild // S "webhooks" - & giveID gid - & buildRoute - route (GetWebhook (getID @Webhook -> wid)) = baseRoute wid - & buildRoute - route (GetWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t - & buildRoute - route (ModifyWebhook (getID @Webhook -> wid) _) = baseRoute wid - & buildRoute - route (ModifyWebhookToken (getID @Webhook -> wid) t _) = baseRoute wid // S t - & buildRoute - route (DeleteWebhook (getID @Webhook -> wid)) = baseRoute wid - & buildRoute - route (DeleteWebhookToken (getID @Webhook -> wid) t) = baseRoute wid // S t - & buildRoute - route (ExecuteWebhook (getID @Webhook -> wid) t _) = baseRoute wid // S t - & buildRoute - - action (CreateWebhook _ o) = postWith' (toJSON o) - action (GetChannelWebhooks _) = getWith - action (GetGuildWebhooks _) = getWith - action (GetWebhook _) = getWith - action (GetWebhookToken _ _) = getWith - action (ModifyWebhook _ o) = patchWith' (toJSON o) - action (ModifyWebhookToken _ _ o) = patchWith' (toJSON o) - action (DeleteWebhook _) = deleteWith - action (DeleteWebhookToken _ _) = deleteWith - action (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Nothing }) = postWithP' - (toJSON . upcast @ExecuteWebhookJson $ o) (param "wait" .~ maybeToList (showt <$> o ^. #wait)) - action (ExecuteWebhook _ _ o@ExecuteWebhookOptions { file = Just f }) = postWithP' - [partLBS @IO "file" f, partLBS "payload_json" (encode . upcast @ExecuteWebhookJson $ o)] - (param "wait" .~ maybeToList (showt <$> o ^. #wait)) diff --git a/src/Calamity/Internal/AesonThings.hs b/src/Calamity/Internal/AesonThings.hs deleted file mode 100644 --- a/src/Calamity/Internal/AesonThings.hs +++ /dev/null @@ -1,140 +0,0 @@ -module Calamity.Internal.AesonThings - ( WithSpecialCases(..) - , IfNoneThen - , ExtractFieldFrom - , ExtractFieldInto - , ExtractFields - , ExtractArrayField - , DefaultToEmptyArray - , DefaultToZero - , DefaultToFalse - , CalamityJSON(..) - , CalamityJSONKeepNothing(..) - , jsonOptions - , jsonOptionsKeepNothing ) where - -import Control.Lens - -import Data.Aeson -import Data.Aeson.Lens -import Data.Aeson.Types ( Parser ) -import Data.Kind -import Data.Reflection ( Reifies(..) ) -import Data.Text ( Text ) -import Data.Text.Strict.Lens -import Data.Typeable - -import GHC.Generics -import GHC.TypeLits ( KnownSymbol, symbolVal ) -import Control.Monad ((>=>)) - -textSymbolVal :: forall n. KnownSymbol n => Text -textSymbolVal = symbolVal @n Proxy ^. packed - -data IfNoneThen label def -data ExtractFieldInto label field target -type ExtractFieldFrom label field = ExtractFieldInto label field label -data ExtractFields label fields -data ExtractArrayField label field - -class PerformAction action where - runAction :: Proxy action -> Object -> Parser Object - -instance (Reifies d Value, KnownSymbol label) => PerformAction (IfNoneThen label d) where - runAction _ o = do - v <- o .:? textSymbolVal @label .!= reflect @d Proxy - pure $ o & at (textSymbolVal @label) ?~ v - -instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where - runAction _ o = - let v :: Maybe Value = o ^? ix (textSymbolVal @label) . _Object . ix (textSymbolVal @field) - in pure $ o & at (textSymbolVal @target) .~ v - -instance PerformAction (ExtractFields label '[]) where - runAction _ = pure - -instance (KnownSymbol field, - PerformAction (ExtractFieldInto label field field), - PerformAction (ExtractFields label fields)) => - PerformAction (ExtractFields label (field : fields)) where - runAction _ = runAction (Proxy @(ExtractFieldInto label field field)) >=> runAction (Proxy @(ExtractFields label fields)) - -instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where - runAction _ o = do - a :: Maybe Array <- o .:? textSymbolVal @label - case a of - Just a' -> do - a'' <- Array <$> traverse (withObject "extracting field" (.: textSymbolVal @field)) a' - pure $ o & at (textSymbolVal @label) ?~ a'' - Nothing -> pure o - -newtype WithSpecialCases (rules :: [Type]) a = WithSpecialCases a - -class RunSpecialCase a where - runSpecialCases :: Proxy a -> Object -> Parser Object - -instance RunSpecialCase '[] where - runSpecialCases _ = pure . id - -instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where - runSpecialCases _ o = do - o' <- runSpecialCases (Proxy @xs) o - runAction (Proxy @action) o' - -instance (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a)) - => FromJSON (WithSpecialCases rules a) where - parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do - o' <- runSpecialCases (Proxy @rules) o - WithSpecialCases <$> genericParseJSON jsonOptions (Object o') - - -data DefaultToEmptyArray - -instance Reifies DefaultToEmptyArray Value where - reflect _ = Array mempty - -data DefaultToZero - -instance Reifies DefaultToZero Value where - reflect _ = Number 0 - -data DefaultToFalse - -instance Reifies DefaultToFalse Value where - reflect _ = Bool False - -newtype CalamityJSON a = CalamityJSON - { unCalamityJSON :: a - } - -instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSON a) where - toJSON = genericToJSON jsonOptions . unCalamityJSON - - toEncoding = genericToEncoding jsonOptions . unCalamityJSON - -instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSON a) where - parseJSON = fmap CalamityJSON . genericParseJSON jsonOptions - --- | version that keeps Nothing fields -newtype CalamityJSONKeepNothing a = CalamityJSONKeepNothing - { unCalamityJSONKeepNothing :: a - } - -instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSONKeepNothing a) where - toJSON = genericToJSON jsonOptionsKeepNothing . unCalamityJSONKeepNothing - - toEncoding = genericToEncoding jsonOptionsKeepNothing . unCalamityJSONKeepNothing - -instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSONKeepNothing a) where - parseJSON = fmap CalamityJSONKeepNothing . genericParseJSON jsonOptionsKeepNothing - -jsonOptions :: Options -jsonOptions = defaultOptions { sumEncoding = UntaggedValue - , fieldLabelModifier = camelTo2 '_' . filter (/= '_') - , omitNothingFields = True } - -jsonOptionsKeepNothing :: Options -jsonOptionsKeepNothing = defaultOptions { sumEncoding = UntaggedValue - , fieldLabelModifier = camelTo2 '_' . filter (/= '_') - , omitNothingFields = False } - diff --git a/src/Calamity/Internal/BoundedStore.hs b/src/Calamity/Internal/BoundedStore.hs deleted file mode 100644 --- a/src/Calamity/Internal/BoundedStore.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | A thing for storing the last N things with IDs -module Calamity.Internal.BoundedStore - ( BoundedStore - , empty - , addItem - , getItem - , dropItem ) where - -import Calamity.Internal.Utils -import Calamity.Types.Snowflake - -import Control.Lens -import Control.Monad.State.Lazy - -import Data.Default.Class -import Data.Generics.Labels () -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as H - -import qualified Deque.Lazy as DQ -import Deque.Lazy ( Deque ) - -import GHC.Generics - -data BoundedStore a = BoundedStore - { itemQueue :: Deque (Snowflake a) - , items :: HashMap (Snowflake a) a - , limit :: Int - , size :: Int - } - deriving ( Show, Generic ) - -instance Foldable BoundedStore where - foldr f i = foldr f i . H.elems . items - -instance Default (BoundedStore a) where - def = BoundedStore mempty mempty 1000 0 - -empty :: Int -> BoundedStore a -empty limit = BoundedStore mempty mempty limit 0 - -type instance (Index (BoundedStore a)) = Snowflake a - -type instance (IxValue (BoundedStore a)) = a - -instance HasID' a => Ixed (BoundedStore a) - -instance HasID' a => At (BoundedStore a) where - at k f m = f mv <&> \case - Nothing -> maybe m (const (dropItem k m)) mv - Just v -> addItem v m - where - mv = getItem k m - - {-# INLINE at #-} - -addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a -addItem m = execState $ do - unlessM (H.member (getID m) <$> use #items) $ do - #itemQueue %= DQ.cons (getID m) - #size += 1 - - size <- use #size - limit <- use #limit - - when (size > limit) $ do - q <- use #itemQueue - let Just (rid, q') = DQ.unsnoc q - #itemQueue .= q' - #items %= sans rid - #size -= 1 - - #items %= H.insert (getID m) m - -{-# INLINE addItem #-} - -getItem :: Snowflake a -> BoundedStore a -> Maybe a -getItem id s = H.lookup id (s ^. #items) - -{-# INLINE getItem #-} - -dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a -dropItem id = execState $ do - whenM (H.member id <$> use #items) $ do - #size -= 1 - - #itemQueue %= DQ.filter (/= id) - #items %= H.delete id - -{-# INLINE dropItem #-} diff --git a/src/Calamity/Internal/ConstructorName.hs b/src/Calamity/Internal/ConstructorName.hs deleted file mode 100644 --- a/src/Calamity/Internal/ConstructorName.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | Get the constructor name of something -module Calamity.Internal.ConstructorName - ( CtorName(..) - , GCtorName(..) ) where - -import GHC.Generics - -class GCtorName f where - gctorName :: f a -> String - -instance Constructor c => GCtorName (C1 c f) where - gctorName = conName - -instance GCtorName f => GCtorName (D1 d f) where - gctorName (M1 a) = gctorName a - -instance (GCtorName f, GCtorName g) => GCtorName (f :+: g) where - gctorName (L1 a) = gctorName a - gctorName (R1 a) = gctorName a - -class CtorName a where - ctorName :: a -> String - default ctorName :: (Generic a, GCtorName (Rep a)) => a -> String - ctorName = gctorName . from diff --git a/src/Calamity/Internal/IntColour.hs b/src/Calamity/Internal/IntColour.hs deleted file mode 100644 --- a/src/Calamity/Internal/IntColour.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | An orphan instnace to parse @'Data.Colour' 'Double'@ as a word64 -module Calamity.Internal.IntColour - ( colourToWord64 - , colourFromWord64 ) where - -import Data.Aeson -import Data.Bits -import Data.Colour -import Data.Colour.SRGB ( RGB(RGB), sRGB24, toSRGB24 ) -import Data.Word ( Word64 ) - -colourToWord64 :: Colour Double -> Word64 -colourToWord64 c = let RGB r g b = toSRGB24 c - i = (fromIntegral r `shiftL` 16) .|. (fromIntegral g `shiftL` 8) .|. fromIntegral b - in i - -colourFromWord64 :: Word64 -> Colour Double -colourFromWord64 i = let r = (i `shiftR` 16) .&. 0xff - g = (i `shiftR` 8) .&. 0xff - b = i .&. 0xff - in sRGB24 (fromIntegral r) (fromIntegral g) (fromIntegral b) - -instance ToJSON (Colour Double) where - toJSON = toJSON . colourToWord64 - -instance FromJSON (Colour Double) where - parseJSON v = colourFromWord64 <$> parseJSON v diff --git a/src/Calamity/Internal/LocalWriter.hs b/src/Calamity/Internal/LocalWriter.hs deleted file mode 100644 --- a/src/Calamity/Internal/LocalWriter.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | A Writer monad that supports local writing, reverse reader I guess? -module Calamity.Internal.LocalWriter - ( LocalWriter(..) - , ltell - , llisten - , runLocalWriter ) where - -import qualified Polysemy as P -import qualified Polysemy.State as P - -data LocalWriter o m a where - Ltell :: o -> LocalWriter o m () - Llisten :: m a -> LocalWriter o m (o, a) - -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) diff --git a/src/Calamity/Internal/RunIntoIO.hs b/src/Calamity/Internal/RunIntoIO.hs deleted file mode 100644 --- a/src/Calamity/Internal/RunIntoIO.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Something for converting polysemy actions into IO actions -module Calamity.Internal.RunIntoIO - ( runSemToIO - , bindSemToIO ) where - -import Data.Functor - -import qualified Polysemy as P -import qualified Polysemy.Final 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 - m' <- P.runS m - ins <- P.getInspectorS - P.liftS $ pure (P.inspect ins <$> m') - -bindSemToIO :: forall r p a. P.Member (P.Final IO) r => (p -> P.Sem r a) -> P.Sem r (p -> IO (Maybe a)) -bindSemToIO m = P.withStrategicToFinal $ do - istate <- P.getInitialStateS - m' <- P.bindS m - ins <- P.getInspectorS - P.liftS $ pure (\x -> P.inspect ins <$> m' (istate $> x)) diff --git a/src/Calamity/Internal/SnowflakeMap.hs b/src/Calamity/Internal/SnowflakeMap.hs deleted file mode 100644 --- a/src/Calamity/Internal/SnowflakeMap.hs +++ /dev/null @@ -1,242 +0,0 @@ --- | Module for custom instance of Data.HashMap.Lazy that decodes from any list of objects that have an id field -module Calamity.Internal.SnowflakeMap where - -import Calamity.Internal.Utils () -import Calamity.Types.Snowflake - -import Control.DeepSeq -import Control.Lens.At -import Control.Lens.Iso -import Control.Lens.Wrapped - -import Data.Aeson ( FromJSON(..), ToJSON(..), withArray ) -import Data.Data -import qualified Data.Foldable as F -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as LH -import Data.Hashable - -import GHC.Exts ( IsList ) -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -import Unsafe.Coerce - -newtype SnowflakeMap a = SnowflakeMap - { unSnowflakeMap :: HashMap (Snowflake a) a - } - deriving ( Generic, Eq, Data, Ord, Show ) - deriving ( TextShow ) via TSG.FromGeneric (SnowflakeMap a) - deriving newtype ( IsList, Semigroup, Monoid ) - deriving anyclass ( NFData, Hashable ) - --- instance At (SnowflakeMap a) where --- at k f m = at (unSnowflakeMap k) f m - -instance Functor SnowflakeMap where - fmap f = SnowflakeMap . coerceSnowflakeMap . fmap f . unSnowflakeMap - -instance Foldable SnowflakeMap where - foldr f b = Prelude.foldr f b . unSnowflakeMap - -instance Traversable SnowflakeMap where - traverse f = fmap (SnowflakeMap . coerceSnowflakeMap) . traverse f . unSnowflakeMap - --- deriving instance NFData a => NFData (SnowflakeMap a) - --- deriving instance Hashable a => Hashable (SnowflakeMap a) - -instance Wrapped (SnowflakeMap a) where - type Unwrapped (SnowflakeMap a) = HashMap (Snowflake a) a - - _Wrapped' = iso unSnowflakeMap SnowflakeMap - -type instance (Index (SnowflakeMap a)) = Snowflake a - -type instance (IxValue (SnowflakeMap a)) = a - -instance SnowflakeMap a ~ t => Rewrapped (SnowflakeMap b) a - -instance Ixed (SnowflakeMap a) where - ix i = _Wrapped . ix i - -instance At (SnowflakeMap a) where - at i = _Wrapped . at i - -over :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b -over f = SnowflakeMap . f . unSnowflakeMap -{-# INLINABLE over #-} - --- SAFETY: 'Snowflake' always uses the underlying hash function (Word64) -coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v -coerceSnowflakeMap = unsafeCoerce -{-# INLINABLE coerceSnowflakeMap #-} - -empty :: SnowflakeMap a -empty = SnowflakeMap LH.empty -{-# INLINABLE empty #-} - -singleton :: HasID' a => a -> SnowflakeMap a -singleton v = SnowflakeMap $ LH.singleton (getID v) v -{-# INLINABLE singleton #-} - -null :: SnowflakeMap a -> Bool -null = LH.null . unSnowflakeMap -{-# INLINABLE null #-} - -size :: SnowflakeMap a -> Int -size = LH.size . unSnowflakeMap -{-# INLINABLE size #-} - -member :: Snowflake a -> SnowflakeMap a -> Bool -member k = LH.member k . unSnowflakeMap -{-# INLINABLE member #-} - -lookup :: Snowflake a -> SnowflakeMap a -> Maybe a -lookup k = LH.lookup k . unSnowflakeMap -{-# INLINABLE lookup #-} - -lookupDefault :: a -> Snowflake a -> SnowflakeMap a -> a -lookupDefault d k = LH.lookupDefault d k . unSnowflakeMap -{-# INLINABLE lookupDefault #-} - -(!) :: SnowflakeMap a -> Snowflake a -> a -(!) m k = unSnowflakeMap m LH.! k -{-# INLINABLE (!) #-} - -infixl 9 ! - -insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a -insert v = over $ LH.insert (getID v) v -{-# INLINABLE insert #-} - -insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a -insertWith f v = over $ LH.insertWith f (getID v) v -{-# INLINABLE insertWith #-} - -delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a -delete k = over $ LH.delete k -{-# INLINABLE delete #-} - -adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -adjust f k = over $ LH.adjust f k -{-# INLINABLE adjust #-} - -update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -update f k = over $ LH.update f k -{-# INLINABLE update #-} - -alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -alter f k = over $ LH.alter f k -{-# INLINABLE alter #-} - -union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -union m m' = SnowflakeMap $ LH.union (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE union #-} - -unionWith :: (a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -unionWith f m m' = SnowflakeMap $ LH.unionWith f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE unionWith #-} - -unionWithKey :: (Snowflake a -> a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -unionWithKey f m m' = SnowflakeMap $ LH.unionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE unionWithKey #-} - -unions :: [SnowflakeMap a] -> SnowflakeMap a -unions = SnowflakeMap . LH.unions . Prelude.map unSnowflakeMap -{-# INLINABLE unions #-} - -map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 -map f = over $ coerceSnowflakeMap . LH.map f -{-# INLINABLE map #-} - -mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 -mapWithKey f = over $ coerceSnowflakeMap . LH.mapWithKey f -{-# INLINABLE mapWithKey #-} - -traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) -traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . LH.traverseWithKey f . unSnowflakeMap -{-# INLINABLE traverseWithKey #-} - -difference :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -difference m m' = SnowflakeMap $ LH.difference (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE difference #-} - -differenceWith :: (a -> a -> Maybe a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -differenceWith f m m' = SnowflakeMap $ LH.differenceWith f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE differenceWith #-} - -intersection :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -intersection m m' = SnowflakeMap $ LH.intersection (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE intersection #-} - -intersectionWith :: (a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b -intersectionWith f m m' = SnowflakeMap . coerceSnowflakeMap $ LH.intersectionWith f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE intersectionWith #-} - -intersectionWithKey :: (Snowflake a -> a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b -intersectionWithKey f m m' = SnowflakeMap . coerceSnowflakeMap $ LH.intersectionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE intersectionWithKey #-} - -foldl' :: (a -> b -> a) -> a -> SnowflakeMap b -> a -foldl' f s m = LH.foldl' f s $ unSnowflakeMap m -{-# INLINABLE foldl' #-} - -foldlWithKey' :: (a -> Snowflake b -> b -> a) -> a -> SnowflakeMap b -> a -foldlWithKey' f s m = LH.foldlWithKey' f s $ unSnowflakeMap m -{-# INLINABLE foldlWithKey' #-} - -foldr :: (b -> a -> a) -> a -> SnowflakeMap b -> a -foldr f s m = LH.foldr f s $ unSnowflakeMap m -{-# INLINABLE foldr #-} - -foldrWithKey :: (Snowflake b -> b -> a -> a) -> a -> SnowflakeMap b -> a -foldrWithKey f s m = LH.foldrWithKey f s $ unSnowflakeMap m -{-# INLINABLE foldrWithKey #-} - -filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a -filter f = over $ LH.filter f -{-# INLINABLE filter #-} - -filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a -filterWithKey f = over $ LH.filterWithKey f -{-# INLINABLE filterWithKey #-} - -mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b -mapMaybe f = over $ coerceSnowflakeMap . LH.mapMaybe f -{-# INLINABLE mapMaybe #-} - -mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b -mapMaybeWithKey f = over $ coerceSnowflakeMap . LH.mapMaybeWithKey f -{-# INLINABLE mapMaybeWithKey #-} - -keys :: SnowflakeMap a -> [Snowflake a] -keys = LH.keys . unSnowflakeMap -{-# INLINABLE keys #-} - -elems :: SnowflakeMap a -> [a] -elems = LH.elems . unSnowflakeMap -{-# INLINABLE elems #-} - -toList :: SnowflakeMap a -> [(Snowflake a, a)] -toList = LH.toList . unSnowflakeMap -{-# INLINABLE toList #-} - -fromList :: HasID' a => [a] -> SnowflakeMap a -fromList = SnowflakeMap . LH.fromList . Prelude.map (\v -> (getID v, v)) -{-# INLINABLE fromList #-} - -fromListWith :: HasID' a => (a -> a -> a) -> [a] -> SnowflakeMap a -fromListWith f = SnowflakeMap . LH.fromListWith f . Prelude.map (\v -> (getID v, v)) -{-# INLINABLE fromListWith #-} - -instance (FromJSON a, HasID' a) => FromJSON (SnowflakeMap a) where - parseJSON = withArray "SnowflakeMap" $ \l -> do - parsed <- traverse parseJSON l - pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed - -instance ToJSON a => ToJSON (SnowflakeMap a) where - toJSON = toJSON . elems - toEncoding = toEncoding . elems diff --git a/src/Calamity/Internal/Updateable.hs b/src/Calamity/Internal/Updateable.hs deleted file mode 100644 --- a/src/Calamity/Internal/Updateable.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | Updateable objects -module Calamity.Internal.Updateable - ( Updateable(..) ) where - -import Calamity.Internal.Utils -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Channel.UpdatedMessage -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User - -import Control.Lens - -import Data.Generics.Product.Fields -import Data.Maybe - -import GHC.TypeLits - -class Updateable a where - type Updated a - type Updated a = a - - update :: Updated a -> a -> a - --- | sets original field to new field -setF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n b) => n -> o -> o -setF n = field' @f .~ (n ^. field' @f) - --- | sets original field to unwrapped new field if new field is not Nothing -mergeF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n (Maybe b)) => o -> n -> o -> o -mergeF o n = field' @f .~ fromMaybe (o ^. field' @f) (n ^. field' @f) - --- | sets original field to new field if new field is not Nothing -mergeF' :: forall (f :: Symbol) o n b. (HasField' f o (Maybe b), HasField' f n (Maybe b)) => o -> n -> o -> o -mergeF' o n = field' @f .~ lastMaybe (o ^. field' @f) (n ^. field' @f) - -instance Updateable Message where - type Updated Message = UpdatedMessage - - update n o = o - & mergeF @"content" o n - & setF @"editedTimestamp" n - & mergeF @"tts" o n - & mergeF @"mentionEveryone" o n - & mergeF @"mentions" o n - & mergeF @"mentionRoles" o n - & mergeF' @"mentionChannels" o n - & mergeF @"attachments" o n - & mergeF @"embeds" o n - & mergeF @"reactions" o n - & mergeF @"pinned" o n - -instance Updateable Channel where - update n _ = n - -instance Updateable DMChannel where - update n _ = n - -instance Updateable GuildChannel where - update n _ = n - -instance Updateable Guild where - type Updated Guild = UpdatedGuild - - -- For updating guild we just put in the non-present data from - update n o = o - & setF @"name" n - & setF @"icon" n - & setF @"splash" n - & setF @"owner" n - & setF @"ownerID" n - & mergeF @"permissions" o n - & setF @"region" n - & setF @"afkChannelID" n - & setF @"afkTimeout" n - & mergeF @"embedEnabled" o n - & setF @"embedChannelID" n - & setF @"verificationLevel" n - & setF @"defaultMessageNotifications" n - & setF @"explicitContentFilter" n - & setF @"roles" n - & setF @"features" n - & setF @"mfaLevel" n - & setF @"applicationID" n - & mergeF @"widgetEnabled" o n - & setF @"widgetChannelID" n - & setF @"systemChannelID" n - -instance Updateable User where - update n o = o - & setF @"username" n - & setF @"discriminator" n - & mergeF' @"bot" o n - & mergeF' @"avatar" o n - & mergeF' @"mfaEnabled" o n - & mergeF' @"verified" o n - & mergeF' @"email" o n - & mergeF' @"flags" o n - & mergeF' @"premiumType" o n diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs deleted file mode 100644 --- a/src/Calamity/Internal/Utils.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Internal utilities and instances -module Calamity.Internal.Utils - ( whileMFinalIO - , untilJustFinalIO - , whenJust - , whenM - , unlessM - , lastMaybe - , leftToMaybe - , rightToMaybe - , justToEither - , (<<$>>) - , (<<*>>) - , (<.>) - , debug - , info - , Calamity.Internal.Utils.error - , swap ) where - -import Calamity.Types.LogEff -import Calamity.Internal.RunIntoIO - -import Control.Applicative - -import Data.Default.Class -import qualified Data.HashMap.Lazy as LH -import qualified Data.Map as M -import Data.Semigroup ( Last(..) ) -import Data.Text.Lazy -import Data.Time -import qualified Data.Vector.Unboxing as VU -import Data.Vector.Unboxing ( Vector ) -import Data.Aeson - -import qualified DiPolysemy as Di - -import qualified Polysemy as P - -import TextShow -import Data.Colour (Colour) - --- | Like whileM, but stateful effects are not preserved to mitigate memory leaks --- --- This means Polysemy.Error won't work to break the loop, etc. --- Instead, Error/Alternative will just result in the loop quitting. -whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r () -whileMFinalIO action = do - action' <- runSemToIO action - P.embedFinal $ go action' - where go action' = do - r <- action' - case r of - Just True -> - go action' - _ -> - pure () - --- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks --- --- This means Polysemy.Error won't work to break the loop, etc. --- Instead, Error/Alternative will just result in another loop. -untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a -untilJustFinalIO action = do - action' <- runSemToIO action - P.embedFinal $ go action' - where go action' = do - r <- action' - case r of - Just (Just a) -> - pure a - _ -> - go action' - -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () -whenJust = flip $ maybe (pure ()) - -whenM :: Monad m => m Bool -> m () -> m () -whenM p m = p >>= \case - True -> m - False -> pure () - -unlessM :: Monad m => m Bool -> m () -> m () -unlessM = whenM . (not <$>) - -lastMaybe :: Maybe a -> Maybe a -> Maybe a -lastMaybe l r = getLast <$> fmap Last l <> fmap Last r - -leftToMaybe :: Either e a -> Maybe e -leftToMaybe (Left x) = Just x -leftToMaybe _ = Nothing - -rightToMaybe :: Either e a -> Maybe a -rightToMaybe (Right x) = Just x -rightToMaybe _ = Nothing - -justToEither :: Maybe e -> Either e () -justToEither (Just x) = Left x -justToEither _ = Right () - -(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(<<$>>) = fmap . fmap - -infixl 4 <<$>> - -(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) -(<<*>>) = liftA2 (<*>) - -infixl 4 <<*>> - -(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b) -(<.>) f g x = f <$> g x - -infixl 4 <.> - -debug :: P.Member LogEff r => Text -> P.Sem r () -debug = Di.debug - -info :: P.Member LogEff r => Text -> P.Sem r () -info = Di.info - -error :: P.Member LogEff r => Text -> P.Sem r () -error = Di.error - -swap :: (a, b) -> (b, a) -swap ~(a, b) = (b, a) - -instance TextShow UTCTime where - showb = fromString . show - -instance (TextShow a, VU.Unboxable a) => TextShow (Vector a) where - showb = showbList . VU.toList - -instance (Show k, Show v) => TextShow (LH.HashMap k v) where - showb = fromString . show - -instance (Show k, Show v) => TextShow (M.Map k v) where - showb = fromString . show - -instance (Show a, Fractional a) => TextShow (Colour a) where - showb = fromString . show - -instance Default (M.Map k v) where - def = M.empty - -instance (FromJSON a, VU.Unboxable a) => FromJSON (VU.Vector a) where - parseJSON = (VU.fromList <$>) . parseJSON - -instance (ToJSON a, VU.Unboxable a) => ToJSON (VU.Vector a) where - toJSON = toJSON . VU.toList - toEncoding = toEncoding . VU.toList diff --git a/src/Calamity/Metrics/Eff.hs b/src/Calamity/Metrics/Eff.hs deleted file mode 100644 --- a/src/Calamity/Metrics/Eff.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | Effect for handling metrics -module Calamity.Metrics.Eff - ( Counter - , Gauge - , Histogram - , HistogramSample(..) - , MetricEff(..) - , registerCounter - , registerGauge - , registerHistogram - , addCounter - , modifyGauge - , observeHistogram ) where - -import Calamity.Internal.Utils () -import Calamity.Metrics.Internal - -import Data.Default.Class -import Data.Map -import Data.Text - -import GHC.Generics - -import Polysemy - -import TextShow -import qualified TextShow.Generic as TSG - -data HistogramSample = HistogramSample - { buckets :: Map Double Double - , sum :: Double - , count :: Int - } - deriving ( Eq, Show, Generic, Default ) - deriving ( TextShow ) via TSG.FromGeneric HistogramSample - -data MetricEff m a where - -- | Register a 'Counter' - RegisterCounter :: Text -- ^ Name - -> [(Text, Text)] -- ^ Labels - -> MetricEff m Counter - - -- | Register a 'Gauge' - RegisterGauge :: Text -- ^ Name - -> [(Text, Text)] -- ^ Labels - -> MetricEff m Gauge - - -- | Register a 'Histogram' - RegisterHistogram :: Text -- ^ Name - -> [(Text, Text)] -- ^ Labels - -> [Double] -- ^ Upper bounds - -> MetricEff m Histogram - - AddCounter :: Int -> Counter -> MetricEff m Int - - ModifyGauge :: (Double -> Double) -> Gauge -> MetricEff m Double - - ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample - -makeSem ''MetricEff diff --git a/src/Calamity/Metrics/Internal.hs b/src/Calamity/Metrics/Internal.hs deleted file mode 100644 --- a/src/Calamity/Metrics/Internal.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Internal data structures to the metrics effect -module Calamity.Metrics.Internal - ( Counter(..) - , Gauge(..) - , Histogram(..) ) where - --- | A handle to a counter -newtype Counter = Counter - { unCounter :: Int - } - --- | A handle to a gauge -newtype Gauge = Gauge - { unGauge :: Int - } - --- | A handle to a histogram -newtype Histogram = Histogram - { unHistogram :: Int - } diff --git a/src/Calamity/Metrics/Noop.hs b/src/Calamity/Metrics/Noop.hs deleted file mode 100644 --- a/src/Calamity/Metrics/Noop.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Noop handler for metrics -module Calamity.Metrics.Noop - ( runMetricsNoop ) where - -import Calamity.Metrics.Eff -import Calamity.Metrics.Internal - -import Data.Default.Class - -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 diff --git a/src/Calamity/Types.hs b/src/Calamity/Types.hs deleted file mode 100644 --- a/src/Calamity/Types.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | All user facing types -module Calamity.Types - ( module Calamity.Types.Model - , module Calamity.Types.Partial - , module Calamity.Types.Snowflake - , module Calamity.Types.Token - , module Calamity.Types.Tellable - , module Calamity.Types.Upgradeable - , module Calamity.Types.UnixTimestamp - -- * Types - -- $typesDocs - ) where - -import Calamity.Types.Model -import Calamity.Types.Partial -import Calamity.Types.Snowflake -import Calamity.Types.Token -import Calamity.Types.Tellable -import Calamity.Types.Upgradeable -import Calamity.Types.UnixTimestamp - --- $typesDocs --- --- This module collects all discord models, and other useful types together. --- --- The 'Tellable' class allows you to construct and send --- messages to things to you can send messages to in a neat way. --- --- The 'Upgradeable' class allows you to upgrade a snowflake to the full value --- it refers to. diff --git a/src/Calamity/Types/LogEff.hs b/src/Calamity/Types/LogEff.hs deleted file mode 100644 --- a/src/Calamity/Types/LogEff.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - --- | The logging effect we use -module Calamity.Types.LogEff - ( LogEff - , LogC ) where - -import qualified Df1 - -import DiPolysemy - -import qualified Polysemy as P - -type LogEff = Di Df1.Level Df1.Path Df1.Message - -type LogC r = P.Member LogEff r diff --git a/src/Calamity/Types/Model.hs b/src/Calamity/Types/Model.hs deleted file mode 100644 --- a/src/Calamity/Types/Model.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | Discord data models -module Calamity.Types.Model - ( module Calamity.Types.Model.Channel - , module Calamity.Types.Model.Guild - , module Calamity.Types.Model.Presence - , module Calamity.Types.Model.User - , module Calamity.Types.Model.Voice ) where - -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.Presence -import Calamity.Types.Model.User -import Calamity.Types.Model.Voice diff --git a/src/Calamity/Types/Model/Channel.hs b/src/Calamity/Types/Model/Channel.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | The generic channel type -module Calamity.Types.Model.Channel - ( Channel(..) - , Partial(PartialChannel) - , module Calamity.Types.Model.Channel.DM - , module Calamity.Types.Model.Channel.Group - , module Calamity.Types.Model.Channel.Guild - , module Calamity.Types.Model.Channel.Attachment - , module Calamity.Types.Model.Channel.Reaction - , module Calamity.Types.Model.Channel.Webhook - , module Calamity.Types.Model.Channel.Embed - , module Calamity.Types.Model.Channel.ChannelType - , module Calamity.Types.Model.Channel.Message ) where - -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel.Attachment -import Calamity.Types.Model.Channel.ChannelType -import Calamity.Types.Model.Channel.DM -import Calamity.Types.Model.Channel.Embed -import Calamity.Types.Model.Channel.Group -import Calamity.Types.Model.Channel.Guild -import {-# SOURCE #-} Calamity.Types.Model.Channel.Message -import Calamity.Types.Model.Channel.Reaction -import Calamity.Types.Model.Channel.Webhook -import Calamity.Types.Partial -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Channel - = DMChannel' DMChannel - | GroupChannel' GroupChannel - | GuildChannel' GuildChannel - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Channel - -instance HasID Channel Channel where - getID (DMChannel' a) = getID a - getID (GroupChannel' a) = getID a - getID (GuildChannel' a) = getID a - -instance FromJSON Channel where - parseJSON = withObject "Channel" $ \v -> do - type_ <- v .: "type" - - case type_ of - GuildTextType -> GuildChannel' <$> parseJSON (Object v) - GuildVoiceType -> GuildChannel' <$> parseJSON (Object v) - GuildCategoryType -> GuildChannel' <$> parseJSON (Object v) - DMType -> DMChannel' <$> parseJSON (Object v) - GroupDMType -> GroupChannel' <$> parseJSON (Object v) - -data instance Partial Channel = PartialChannel - { id :: Snowflake Channel - , name :: Text - , type_ :: ChannelType - , parentID :: Maybe (Snowflake Category) - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric (Partial Channel) - deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Channel) - deriving ( HasID Channel ) via HasIDField "id" (Partial Channel) diff --git a/src/Calamity/Types/Model/Channel.hs-boot b/src/Calamity/Types/Model/Channel.hs-boot deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ --- | The generic channel type -module Calamity.Types.Model.Channel - ( Channel ) where - -data Channel -instance Show Channel -instance Eq Channel diff --git a/src/Calamity/Types/Model/Channel/Attachment.hs b/src/Calamity/Types/Model/Channel/Attachment.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Attachment.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | Message attachments -module Calamity.Types.Model.Channel.Attachment - ( Attachment(..) ) where - -import Calamity.Internal.AesonThings () -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Word - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -fuseTup2 :: Monad f => (f a, f b) -> f (a, b) -fuseTup2 (a, b) = do - a' <- a - b' <- b - pure (a', b') - -data Attachment = Attachment - { id :: Snowflake Attachment - , filename :: Text - , size :: Word64 - , url :: Text - , proxyUrl :: Text - , dimensions :: Maybe (Word64, Word64) - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Attachment - deriving ( HasID Attachment ) via HasIDField "id" Attachment - -instance ToJSON Attachment where - toJSON Attachment { id, filename, size, url, proxyUrl, dimensions = Just (width, height) } = object - [ "id" .= id - , "filename" .= filename - , "size" .= size - , "url" .= url - , "proxy_url" .= proxyUrl - , "width" .= width - , "height" .= height] - toJSON Attachment { id, filename, size, url, proxyUrl } = - object ["id" .= id, "filename" .= filename, "size" .= size, "url" .= url, "proxy_url" .= proxyUrl] - -instance FromJSON Attachment where - parseJSON = withObject "Attachment" $ \v -> do - width <- v .:? "width" - height <- v .:? "height" - - Attachment <$> v .: "id" <*> v .: "filename" <*> v .: "size" <*> v .: "url" <*> v .: "proxy_url" <*> pure - (fuseTup2 (width, height)) diff --git a/src/Calamity/Types/Model/Channel/ChannelType.hs b/src/Calamity/Types/Model/Channel/ChannelType.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/ChannelType.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Types of channels -module Calamity.Types.Model.Channel.ChannelType - ( ChannelType(..) ) where - -import Data.Aeson -import Data.Scientific - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - --- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182) -data ChannelType - = GuildTextType - | DMType - | GuildVoiceType - | GroupDMType - | GuildCategoryType - deriving ( Eq, Generic, Show, Enum ) - deriving ( TextShow ) via TSG.FromGeneric ChannelType - -instance ToJSON ChannelType where - toJSON t = Number $ fromIntegral (fromEnum t) - -instance FromJSON ChannelType where - parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of - 0 -> pure GuildTextType - 1 -> pure DMType - 2 -> pure GuildVoiceType - 4 -> pure GuildCategoryType - _ -> fail $ "Invalid ChannelType: " <> show n - Nothing -> fail $ "Invalid ChannelType: " <> show n diff --git a/src/Calamity/Types/Model/Channel/DM.hs b/src/Calamity/Types/Model/Channel/DM.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/DM.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | A DM channel with a single person -module Calamity.Types.Model.Channel.DM - ( DMChannel(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Channel.Message -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Time -import Data.Vector.Unboxing ( Vector ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data DMChannel = DMChannel - { id :: Snowflake DMChannel - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe UTCTime - , recipients :: Vector (Snowflake User) - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric DMChannel - deriving ( FromJSON ) via WithSpecialCases - '["recipients" `ExtractArrayField` "id"] DMChannel - deriving ( HasID DMChannel ) via HasIDField "id" DMChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" DMChannel diff --git a/src/Calamity/Types/Model/Channel/Embed.hs b/src/Calamity/Types/Model/Channel/Embed.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Embed.hs +++ /dev/null @@ -1,142 +0,0 @@ --- | Message embeds -module Calamity.Types.Model.Channel.Embed - ( Embed(..) - , EmbedFooter(..) - , EmbedImage(..) - , EmbedThumbnail(..) - , EmbedVideo(..) - , EmbedProvider(..) - , EmbedAuthor(..) - , EmbedField(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.IntColour () -import Calamity.Internal.Utils () - -import Control.Lens - -import Data.Aeson -import Data.Colour ( Colour ) -import Data.Default.Class -import Data.Generics.Labels () -import Data.Semigroup -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Word - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Embed = Embed - { title :: Maybe Text - , type_ :: Maybe Text - , description :: Maybe Text - , url :: Maybe Text - , timestamp :: Maybe UTCTime - , color :: Maybe (Colour Double) - , footer :: Maybe EmbedFooter - , image :: Maybe EmbedImage - , thumbnail :: Maybe EmbedThumbnail - , video :: Maybe EmbedVideo - , provider :: Maybe EmbedProvider - , author :: Maybe EmbedAuthor - , fields :: [EmbedField] - } - deriving ( Eq, Show, Generic, Default ) - deriving ( TextShow ) via TSG.FromGeneric Embed - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray] Embed - deriving ( ToJSON ) via CalamityJSON Embed - -instance Semigroup Embed where - l <> r = l - & #title %~ (<> (r ^. #title)) - & #type_ %~ getLast . (<> Last (r ^. #type_)) . Last - & #description %~ (<> (r ^. #description)) - & #url %~ getLast . (<> Last (r ^. #url)) . Last - & #timestamp %~ getLast . (<> Last (r ^. #timestamp)) . Last - & #color %~ getLast . (<> Last (r ^. #color)) . Last - & #footer %~ (<> (r ^. #footer)) - & #image %~ getLast . (<> Last (r ^. #image)) . Last - & #thumbnail %~ getLast . (<> Last (r ^. #thumbnail)) . Last - & #video %~ getLast . (<> Last (r ^. #video)) . Last - & #provider %~ getLast . (<> Last (r ^. #provider)) . Last - & #author %~ getLast . (<> Last (r ^. #author)) . Last - & #fields %~ (<> (r ^. #fields)) - -instance Monoid Embed where - mempty = def - -data EmbedFooter = EmbedFooter - { text :: Text - , iconUrl :: Maybe Text - , proxyIconUrl :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedFooter - deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedFooter - -instance Semigroup EmbedFooter where - l <> r = l - & #text %~ (<> (r ^. #text)) - & #iconUrl %~ getLast . (<> Last (r ^. #iconUrl)) . Last - & #proxyIconUrl %~ getLast . (<> Last (r ^. #proxyIconUrl)) . Last - -data EmbedImage = EmbedImage - { url :: Text - , proxyUrl :: Text - , width :: Word64 - , height :: Word64 - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedImage - deriving ( FromJSON, ToJSON ) via CalamityJSON EmbedImage - -data EmbedThumbnail = EmbedThumbnail - { url :: Text - , proxyUrl :: Text - , width :: Word64 - , height :: Word64 - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedThumbnail - deriving ( FromJSON, ToJSON ) via CalamityJSON EmbedThumbnail - -data EmbedVideo = EmbedVideo - { url :: Text - , width :: Word64 - , height :: Word64 - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedVideo - deriving ( FromJSON, ToJSON ) via CalamityJSON EmbedVideo - -data EmbedProvider = EmbedProvider - { name :: Text - , url :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedProvider - deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedProvider - -data EmbedAuthor = EmbedAuthor - { name :: Maybe Text - , url :: Maybe Text - , iconUrl :: Maybe Text - , proxyIconURL :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedAuthor - deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedAuthor - -data EmbedField = EmbedField - { name :: Text - , value :: Text - , inline :: Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric EmbedField - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "inline" DefaultToFalse] - EmbedField - deriving ( ToJSON ) via CalamityJSON EmbedField diff --git a/src/Calamity/Types/Model/Channel/Group.hs b/src/Calamity/Types/Model/Channel/Group.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Group.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | A Group Group channel -module Calamity.Types.Model.Channel.Group - ( GroupChannel(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Channel.Message -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Vector.Unboxing ( Vector ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data GroupChannel = GroupChannel - { id :: Snowflake GroupChannel - , ownerID :: Snowflake User - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe UTCTime - , icon :: Maybe Text - , recipients :: Vector (Snowflake User) - , name :: Text - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric GroupChannel - deriving ( ToJSON, FromJSON ) via CalamityJSON GroupChannel - deriving ( HasID GroupChannel ) via HasIDField "id" GroupChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" GroupChannel - deriving ( HasID User ) via HasIDField "ownerID" GroupChannel diff --git a/src/Calamity/Types/Model/Channel/Guild.hs b/src/Calamity/Types/Model/Channel/Guild.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Guild.hs +++ /dev/null @@ -1,90 +0,0 @@ --- | The generic guild channel type -module Calamity.Types.Model.Channel.Guild - ( GuildChannel(..) - , module Calamity.Types.Model.Channel.Guild.Category - , module Calamity.Types.Model.Channel.Guild.Text - , module Calamity.Types.Model.Channel.Guild.Voice ) where - -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import {-# SOURCE #-} Calamity.Types.Model.Channel -import Calamity.Types.Model.Channel.ChannelType -import Calamity.Types.Model.Channel.Guild.Category -import Calamity.Types.Model.Channel.Guild.Text -import Calamity.Types.Model.Channel.Guild.Voice -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Control.Lens - -import Data.Aeson -import Data.Generics.Product.Fields -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data GuildChannel - = GuildTextChannel TextChannel - | GuildVoiceChannel VoiceChannel - | GuildCategory Category - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric GuildChannel - -instance FromJSON GuildChannel where - parseJSON = withObject "GuildChannel" $ \v -> do - type_ <- v .: "type" - - case type_ of - GuildTextType -> GuildTextChannel <$> parseJSON (Object v) - GuildVoiceType -> GuildVoiceChannel <$> parseJSON (Object v) - GuildCategoryType -> GuildCategory <$> parseJSON (Object v) - typ -> fail $ "Not a valid guild channel: " <> show typ - -instance HasID GuildChannel GuildChannel where - getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"id" - getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"id" - getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"id" - -instance HasID Channel GuildChannel where - getID = coerceSnowflake . getID @GuildChannel - -instance HasID Guild GuildChannel where - getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"guildID" - getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"guildID" - getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"guildID" - -instance {-# OVERLAPS #-}HasField' "name" GuildChannel Text where - field' = lens get set - where - get (GuildTextChannel (TextChannel { name })) = name - get (GuildVoiceChannel (VoiceChannel { name })) = name - get (GuildCategory (Category { name })) = name - - set (GuildTextChannel t) v = GuildTextChannel (t { name = v }) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t { name = v }) - set (GuildCategory t) v = GuildCategory (t { name = v }) - -instance {-# OVERLAPS #-}HasField' "permissionOverwrites" GuildChannel (SnowflakeMap Overwrite) where - field' = lens get set - where - get (GuildTextChannel (TextChannel { permissionOverwrites })) = permissionOverwrites - get (GuildVoiceChannel (VoiceChannel { permissionOverwrites })) = permissionOverwrites - get (GuildCategory (Category { permissionOverwrites })) = permissionOverwrites - - set (GuildTextChannel t) v = GuildTextChannel (t { permissionOverwrites = v }) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t { permissionOverwrites = v }) - set (GuildCategory t) v = GuildCategory (t { permissionOverwrites = v }) - -instance {-# OVERLAPS #-}HasField' "position" GuildChannel Int where - field' = lens get set - where - get (GuildTextChannel (TextChannel { position })) = position - get (GuildVoiceChannel (VoiceChannel { position })) = position - get (GuildCategory (Category { position })) = position - - set (GuildTextChannel t) v = GuildTextChannel (t { position = v }) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t { position = v }) - set (GuildCategory t) v = GuildCategory (t { position = v }) diff --git a/src/Calamity/Types/Model/Channel/Guild/Category.hs b/src/Calamity/Types/Model/Channel/Guild/Category.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Guild/Category.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Calamity.Types.Model.Channel.Guild.Category - ( Category(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Category = Category - { id :: Snowflake Category - , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , nsfw :: Bool - , position :: Int - , guildID :: Snowflake Guild - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Category - deriving ( ToJSON ) via CalamityJSON Category - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "nsfw" DefaultToFalse] Category - deriving ( HasID Category ) via HasIDField "id" Category - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" Category diff --git a/src/Calamity/Types/Model/Channel/Guild/Category.hs-boot b/src/Calamity/Types/Model/Channel/Guild/Category.hs-boot deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Guild/Category.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module Calamity.Types.Model.Channel.Guild.Category - ( Category ) where - - -data Category - -instance Show Category -instance Eq Category diff --git a/src/Calamity/Types/Model/Channel/Guild/Text.hs b/src/Calamity/Types/Model/Channel/Guild/Text.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Guild/Text.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | Text channels -module Calamity.Types.Model.Channel.Guild.Text - ( TextChannel(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category -import {-# SOURCE #-} Calamity.Types.Model.Channel.Message -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data TextChannel = TextChannel - { id :: Snowflake TextChannel - , guildID :: Snowflake Guild - , position :: Int - , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , topic :: Maybe Text - , nsfw :: Bool - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe UTCTime - , rateLimitPerUser :: Maybe Int - , parentID :: Maybe (Snowflake Category) - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric TextChannel - deriving ( ToJSON ) via CalamityJSON TextChannel - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "nsfw" DefaultToFalse] - TextChannel - deriving ( HasID TextChannel ) via HasIDField "id" TextChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" TextChannel - deriving ( HasID Guild ) via HasIDField "guildID" TextChannel diff --git a/src/Calamity/Types/Model/Channel/Guild/Voice.hs b/src/Calamity/Types/Model/Channel/Guild/Voice.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Guild/Voice.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | Voice channels -module Calamity.Types.Model.Channel.Guild.Voice - ( VoiceChannel(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data VoiceChannel = VoiceChannel - { id :: Snowflake VoiceChannel - , guildID :: Snowflake Guild - , position :: Int - , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , bitrate :: Int - , userLimit :: Int - , parentID :: Maybe (Snowflake Category) - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric VoiceChannel - deriving ( ToJSON, FromJSON ) via CalamityJSON VoiceChannel - deriving ( HasID VoiceChannel ) via HasIDField "id" VoiceChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" VoiceChannel - deriving ( HasID Guild ) via HasIDField "guildID" VoiceChannel diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Message.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | A message from a channel -module Calamity.Types.Model.Channel.Message - ( Message(..) - , MessageType(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Scientific -import Data.Text.Lazy ( Text ) -import Data.Time -import qualified Data.Vector.Unboxing as UV - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - --- NOTE: make sure we fill in the guildID field when retrieving from REST -data Message = Message - { id :: Snowflake Message - , channelID :: Snowflake Channel - , guildID :: Maybe (Snowflake Guild) - , author :: Snowflake User - , content :: Text - , timestamp :: UTCTime - , editedTimestamp :: Maybe UTCTime - , tts :: Bool - , mentionEveryone :: Bool - , mentions :: UV.Vector (Snowflake User) - , mentionRoles :: UV.Vector (Snowflake Role) - , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: [Attachment] - , embeds :: [Embed] - , reactions :: [Reaction] - , nonce :: Maybe (Snowflake Message) - , pinned :: Bool - , webhookID :: Maybe (Snowflake ()) - , type_ :: MessageType - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Message - deriving ( FromJSON ) via WithSpecialCases - '["author" `ExtractFieldFrom` "id", "mentions" `ExtractArrayField` "id", - "mention_channels" `ExtractArrayField` "id", - "reactions" `IfNoneThen` DefaultToEmptyArray] - Message - deriving ( HasID Message ) via HasIDField "id" Message - deriving ( HasID Channel ) via HasIDField "channelID" Message - deriving ( HasID User ) via HasIDField "author" Message - --- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L264) -data MessageType - = Default - | RecipientAdd - | RecipientRemove - | Call - | ChannelNameChange - | ChannelIconChange - | ChannelPinnedMessage - | GuildMemberJoin - deriving ( Eq, Show, Enum, Generic ) - deriving ( TextShow ) via TSG.FromGeneric MessageType - -instance FromJSON MessageType where - parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of - 0 -> pure Default - 1 -> pure RecipientAdd - 2 -> pure RecipientRemove - 3 -> pure Call - 4 -> pure ChannelNameChange - 5 -> pure ChannelIconChange - 6 -> pure ChannelPinnedMessage - 7 -> pure GuildMemberJoin - _ -> fail $ "Invalid MessageType: " <> show n - Nothing -> fail $ "Invalid MessageType: " <> show n diff --git a/src/Calamity/Types/Model/Channel/Message.hs-boot b/src/Calamity/Types/Model/Channel/Message.hs-boot deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Message.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ --- | A message from a channel -module Calamity.Types.Model.Channel.Message - ( Message - , MessageType ) where - -data Message - -instance Show Message -instance Eq Message - -data MessageType - -instance Show MessageType -instance Eq MessageType diff --git a/src/Calamity/Types/Model/Channel/Reaction.hs b/src/Calamity/Types/Model/Channel/Reaction.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Reaction.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | Message reactions -module Calamity.Types.Model.Channel.Reaction - ( Reaction(..) ) where - -import Calamity.Internal.AesonThings -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Channel.Message -import Calamity.Types.Model.Guild.Emoji -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Reaction = Reaction - { userID :: Snowflake User - , channelID :: Snowflake Channel - , messageID :: Snowflake Message - , guildID :: Maybe (Snowflake Guild) - , emoji :: RawEmoji - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Reaction - deriving ( ToJSON, FromJSON ) via CalamityJSON Reaction - deriving ( HasID User ) via HasIDField "userID" Reaction - deriving ( HasID Channel ) via HasIDField "channelID" Reaction - deriving ( HasID Message ) via HasIDField "messageID" Reaction diff --git a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | Updated messages -module Calamity.Types.Model.Channel.UpdatedMessage - ( UpdatedMessage(..) - ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time -import qualified Data.Vector.Unboxing as UV - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data UpdatedMessage = UpdatedMessage - { id :: Snowflake Message - , channelID :: Snowflake Channel - , content :: Maybe Text - , editedTimestamp :: Maybe UTCTime - , tts :: Maybe Bool - , mentionEveryone :: Maybe Bool - , mentions :: Maybe (UV.Vector (Snowflake User)) - , mentionRoles :: Maybe (UV.Vector (Snowflake Role)) - , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: Maybe [Attachment] - , embeds :: Maybe [Embed] - , reactions :: Maybe [Reaction] - , pinned :: Maybe Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UpdatedMessage - deriving ( FromJSON ) via WithSpecialCases - '["author" `ExtractFieldFrom` "id", "mentions" `ExtractArrayField` "id", - "mention_channels" `ExtractArrayField` "id"] - UpdatedMessage - deriving ( HasID Message ) via HasIDField "id" UpdatedMessage - deriving ( HasID Channel ) via HasIDField "channelID" UpdatedMessage diff --git a/src/Calamity/Types/Model/Channel/Webhook.hs b/src/Calamity/Types/Model/Channel/Webhook.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Channel/Webhook.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | Channel webhooks -module Calamity.Types.Model.Channel.Webhook - ( Webhook(..) ) where - -import Calamity.Internal.AesonThings -import {-# SOURCE #-} Calamity.Types.Model.Channel -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Webhook = Webhook - { id :: Snowflake Webhook - , type_ :: Integer - , guildID :: Maybe (Snowflake Guild) - , channelID :: Maybe (Snowflake Channel) - , user :: Maybe (Snowflake User) - , name :: Text - , avatar :: Text - , token :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Webhook - deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Webhook - deriving ( HasID Webhook ) via HasIDField "id" Webhook diff --git a/src/Calamity/Types/Model/Guild.hs b/src/Calamity/Types/Model/Guild.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | Discord Guilds -module Calamity.Types.Model.Guild - ( module Calamity.Types.Model.Guild.AuditLog - , module Calamity.Types.Model.Guild.Ban - , module Calamity.Types.Model.Guild.Emoji - , module Calamity.Types.Model.Guild.Guild - , module Calamity.Types.Model.Guild.Member - , module Calamity.Types.Model.Guild.Overwrite - , module Calamity.Types.Model.Guild.Invite - , module Calamity.Types.Model.Guild.Role - , module Calamity.Types.Model.Guild.UnavailableGuild - , module Calamity.Types.Model.Guild.Permissions ) where - -import Calamity.Types.Model.Guild.AuditLog -import Calamity.Types.Model.Guild.Ban -import Calamity.Types.Model.Guild.Emoji -import Calamity.Types.Model.Guild.Guild hiding ( UpdatedGuild(..) ) -import Calamity.Types.Model.Guild.Invite -import Calamity.Types.Model.Guild.Member -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.Guild.UnavailableGuild -import Calamity.Types.Model.Guild.Permissions diff --git a/src/Calamity/Types/Model/Guild/AuditLog.hs b/src/Calamity/Types/Model/Guild/AuditLog.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/AuditLog.hs +++ /dev/null @@ -1,228 +0,0 @@ --- | Audit Log models -module Calamity.Types.Model.Guild.AuditLog - ( AuditLog(..) - , AuditLogEntry(..) - , AuditLogEntryInfo(..) - , AuditLogChange(..) - , AuditLogAction(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Types.Model.Channel -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Scientific -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data AuditLog = AuditLog - { webhooks :: SnowflakeMap Webhook - , users :: SnowflakeMap User - , auditLogEntries :: SnowflakeMap AuditLogEntry - } - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric AuditLog - deriving ( FromJSON ) via CalamityJSON AuditLog - -data AuditLogEntry = AuditLogEntry - { targetID :: Maybe (Snowflake ()) - , changes :: [AuditLogChange] - , userID :: Snowflake User - , id :: Snowflake AuditLogEntry - , actionType :: AuditLogAction - , options :: Maybe AuditLogEntryInfo - , reason :: Maybe Text - } - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric AuditLogEntry - deriving ( FromJSON ) via CalamityJSON AuditLogEntry - deriving ( HasID User ) via HasIDField "userID" AuditLogEntry - deriving ( HasID AuditLogEntry ) via HasIDField "id" AuditLogEntry - -data AuditLogEntryInfo = AuditLogEntryInfo - { deleteMemberDays :: Maybe Text - , membersRemoved :: Maybe Text - , channelID :: Maybe (Snowflake Channel) - , messageID :: Maybe (Snowflake Message) - , count :: Maybe Text - , id :: Maybe (Snowflake ()) - , type_ :: Maybe Text - , roleName :: Maybe Text - } - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric AuditLogEntryInfo - deriving ( FromJSON ) via CalamityJSON AuditLogEntryInfo - -data AuditLogChange = AuditLogChange - { newValue :: Maybe Value - , oldValue :: Maybe Value - , key :: Text - } - deriving ( Show, Generic ) - deriving ( TextShow ) via FromStringShow AuditLogChange - deriving ( FromJSON ) via CalamityJSON AuditLogChange - -data AuditLogAction - = GUILD_UPDATE - | CHANNEL_CREATE - | CHANNEL_UPDATE - | CHANNEL_DELETE - | CHANNEL_OVERWRITE_CREATE - | CHANNEL_OVERWRITE_UPDATE - | CHANNEL_OVERWRITE_DELETE - | MEMBER_KICK - | MEMBER_PRUNE - | MEMBER_BAN_ADD - | MEMBER_BAN_REMOVE - | MEMBER_UPDATE - | MEMBER_ROLE_UPDATE - | MEMBER_MOVE - | MEMBER_DISCONNECT - | BOT_ADD - | ROLE_CREATE - | ROLE_UPDATE - | ROLE_DELETE - | INVITE_CREATE - | INVITE_UPDATE - | INVITE_DELETE - | WEBHOOK_CREATE - | WEBHOOK_UPDATE - | WEBHOOK_DELETE - | EMOJI_CREATE - | EMOJI_UPDATE - | EMOJI_DELETE - | MESSAGE_DELETE - | MESSAGE_BULK_DELETE - | MESSAGE_PIN - | MESSAGE_UNPIN - | INTEGRATION_CREATE - | INTEGRATION_UPDATE - | INTEGRATION_DELETE - deriving ( Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric AuditLogAction - -instance Enum AuditLogAction where - toEnum v = case v of - 1 -> GUILD_UPDATE - 10 -> CHANNEL_CREATE - 11 -> CHANNEL_UPDATE - 12 -> CHANNEL_DELETE - 13 -> CHANNEL_OVERWRITE_CREATE - 14 -> CHANNEL_OVERWRITE_UPDATE - 15 -> CHANNEL_OVERWRITE_DELETE - 20 -> MEMBER_KICK - 21 -> MEMBER_PRUNE - 22 -> MEMBER_BAN_ADD - 23 -> MEMBER_BAN_REMOVE - 24 -> MEMBER_UPDATE - 25 -> MEMBER_ROLE_UPDATE - 26 -> MEMBER_MOVE - 27 -> MEMBER_DISCONNECT - 28 -> BOT_ADD - 30 -> ROLE_CREATE - 31 -> ROLE_UPDATE - 32 -> ROLE_DELETE - 40 -> INVITE_CREATE - 41 -> INVITE_UPDATE - 42 -> INVITE_DELETE - 50 -> WEBHOOK_CREATE - 51 -> WEBHOOK_UPDATE - 52 -> WEBHOOK_DELETE - 60 -> EMOJI_CREATE - 61 -> EMOJI_UPDATE - 62 -> EMOJI_DELETE - 72 -> MESSAGE_DELETE - 73 -> MESSAGE_BULK_DELETE - 74 -> MESSAGE_PIN - 75 -> MESSAGE_UNPIN - 80 -> INTEGRATION_CREATE - 81 -> INTEGRATION_UPDATE - 82 -> INTEGRATION_DELETE - _ -> error $ "Invalid AuditLogAction: " <> show v - - fromEnum v = case v of - GUILD_UPDATE -> 1 - CHANNEL_CREATE -> 10 - CHANNEL_UPDATE -> 11 - CHANNEL_DELETE -> 12 - CHANNEL_OVERWRITE_CREATE -> 13 - CHANNEL_OVERWRITE_UPDATE -> 14 - CHANNEL_OVERWRITE_DELETE -> 15 - MEMBER_KICK -> 20 - MEMBER_PRUNE -> 21 - MEMBER_BAN_ADD -> 22 - MEMBER_BAN_REMOVE -> 23 - MEMBER_UPDATE -> 24 - MEMBER_ROLE_UPDATE -> 25 - MEMBER_MOVE -> 26 - MEMBER_DISCONNECT -> 27 - BOT_ADD -> 28 - ROLE_CREATE -> 30 - ROLE_UPDATE -> 31 - ROLE_DELETE -> 32 - INVITE_CREATE -> 40 - INVITE_UPDATE -> 41 - INVITE_DELETE -> 42 - WEBHOOK_CREATE -> 50 - WEBHOOK_UPDATE -> 51 - WEBHOOK_DELETE -> 52 - EMOJI_CREATE -> 60 - EMOJI_UPDATE -> 61 - EMOJI_DELETE -> 62 - MESSAGE_DELETE -> 72 - MESSAGE_BULK_DELETE -> 73 - MESSAGE_PIN -> 74 - MESSAGE_UNPIN -> 75 - INTEGRATION_CREATE -> 80 - INTEGRATION_UPDATE -> 81 - INTEGRATION_DELETE -> 82 - -instance FromJSON AuditLogAction where - parseJSON = withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of -- no safe toEnum :S - 1 -> pure GUILD_UPDATE - 10 -> pure CHANNEL_CREATE - 11 -> pure CHANNEL_UPDATE - 12 -> pure CHANNEL_DELETE - 13 -> pure CHANNEL_OVERWRITE_CREATE - 14 -> pure CHANNEL_OVERWRITE_UPDATE - 15 -> pure CHANNEL_OVERWRITE_DELETE - 20 -> pure MEMBER_KICK - 21 -> pure MEMBER_PRUNE - 22 -> pure MEMBER_BAN_ADD - 23 -> pure MEMBER_BAN_REMOVE - 24 -> pure MEMBER_UPDATE - 25 -> pure MEMBER_ROLE_UPDATE - 26 -> pure MEMBER_MOVE - 27 -> pure MEMBER_DISCONNECT - 28 -> pure BOT_ADD - 30 -> pure ROLE_CREATE - 31 -> pure ROLE_UPDATE - 32 -> pure ROLE_DELETE - 40 -> pure INVITE_CREATE - 41 -> pure INVITE_UPDATE - 42 -> pure INVITE_DELETE - 50 -> pure WEBHOOK_CREATE - 51 -> pure WEBHOOK_UPDATE - 52 -> pure WEBHOOK_DELETE - 60 -> pure EMOJI_CREATE - 61 -> pure EMOJI_UPDATE - 62 -> pure EMOJI_DELETE - 72 -> pure MESSAGE_DELETE - 73 -> pure MESSAGE_BULK_DELETE - 74 -> pure MESSAGE_PIN - 75 -> pure MESSAGE_UNPIN - 80 -> pure INTEGRATION_CREATE - 81 -> pure INTEGRATION_UPDATE - 82 -> pure INTEGRATION_DELETE - _ -> fail $ "Invalid AuditLogAction: " <> show n - Nothing -> fail $ "Invalid AuditLogAction: " <> show n - -instance ToJSON AuditLogAction where - toJSON = toJSON @Int . fromEnum diff --git a/src/Calamity/Types/Model/Guild/Ban.hs b/src/Calamity/Types/Model/Guild/Ban.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Ban.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Guild ban objects -module Calamity.Types.Model.Guild.Ban - ( BanData(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data BanData = BanData - { guildID :: Snowflake Guild - , user :: User - } - deriving ( Show, Generic ) - deriving ( FromJSON ) via CalamityJSON BanData - deriving ( TextShow ) via TSG.FromGeneric BanData - deriving ( HasID Guild ) via HasIDField "guildID" BanData - deriving ( HasID User ) via HasIDField "user" BanData diff --git a/src/Calamity/Types/Model/Guild/Emoji.hs b/src/Calamity/Types/Model/Guild/Emoji.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Emoji.hs +++ /dev/null @@ -1,89 +0,0 @@ --- | Discord emojis -module Calamity.Types.Model.Guild.Emoji - ( Emoji(..) - , Partial(PartialEmoji) - , RawEmoji(..) - , emojiAsRawEmoji ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import qualified Data.Text.Lazy as L -import Data.Text.Lazy ( Text ) -import Data.Vector.Unboxing ( Vector ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG -import Data.Generics.Product - -data Emoji = Emoji - { id :: Snowflake Emoji - , name :: Text - , roles :: Vector (Snowflake Role) - , user :: Maybe (Snowflake User) - , requireColons :: Bool - , managed :: Bool - , animated :: Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Emoji - deriving ( ToJSON ) via CalamityJSON Emoji - deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Emoji - deriving ( HasID Emoji ) via HasIDField "id" Emoji - -emojiAsRawEmoji :: Emoji -> RawEmoji -emojiAsRawEmoji = CustomEmoji . upcast - -data instance Partial Emoji = PartialEmoji - { id :: Snowflake Emoji - , name :: Text - , animated :: Bool - } - deriving ( Eq, Generic ) - deriving ( ToJSON ) via CalamityJSON (Partial Emoji) - deriving ( FromJSON ) via WithSpecialCases - '["animated" `IfNoneThen` DefaultToFalse] (Partial Emoji) - deriving ( HasID Emoji ) via HasIDField "id" (Partial Emoji) - -instance Show (Partial Emoji) where - show PartialEmoji { id, name, animated } = - "<" <> a <> ":" <> L.unpack name <> ":" <> show id <> ">" - where a = if animated then "a" else "" - -instance TextShow (Partial Emoji) where - showb PartialEmoji { id, name, animated } = - "<" <> a <> ":" <> fromLazyText name <> ":" <> showb id <> ">" - where a = if animated then "a" else "" - -data RawEmoji - = UnicodeEmoji Text - | CustomEmoji (Partial Emoji) - deriving ( Eq, Generic ) - -instance Show RawEmoji where - show (UnicodeEmoji v) = L.unpack v - show (CustomEmoji p) = show p - -instance TextShow RawEmoji where - showb (UnicodeEmoji v) = fromLazyText v - showb (CustomEmoji p) = showb p - -instance ToJSON RawEmoji where - toJSON (CustomEmoji e) = object ["emoji" .= e] - toJSON (UnicodeEmoji s) = object ["emoji" .= object ["name" .= s]] - -instance FromJSON RawEmoji where - parseJSON = withObject "RawEmoji" $ \v -> do - m_id :: Maybe (Snowflake Emoji) <- v .:? "id" - anim <- v .:? "animated" .!= False - name :: Text <- v .: "name" - - pure $ case m_id of - Just id -> CustomEmoji $ PartialEmoji id name anim - Nothing -> UnicodeEmoji name diff --git a/src/Calamity/Types/Model/Guild/Guild.hs b/src/Calamity/Types/Model/Guild/Guild.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Guild.hs +++ /dev/null @@ -1,160 +0,0 @@ --- | Discord Guilds -module Calamity.Types.Model.Guild.Guild - ( Guild(..) - , Partial(PartialGuild) - , UpdatedGuild(..) ) where - -import Calamity.Internal.AesonThings -import qualified Calamity.Internal.SnowflakeMap as SM -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild.Emoji -import {-# SOURCE #-} Calamity.Types.Model.Guild.Member -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.Presence.Presence -import Calamity.Types.Model.User -import Calamity.Types.Model.Voice.VoiceState -import Calamity.Types.Snowflake - -import Control.Lens ( (^.) ) - -import Data.Aeson -import Data.Generics.Product.Fields -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as LH -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Word - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Guild = Guild - { id :: Snowflake Guild - , name :: Text - , icon :: Maybe Text - , splash :: Maybe Text - , owner :: Maybe Bool - , ownerID :: Snowflake User - , permissions :: Word64 - , region :: Text - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Int - , embedEnabled :: Bool - , embedChannelID :: Maybe (Snowflake GuildChannel) - , verificationLevel :: Int - , defaultMessageNotifications :: Int - , explicitContentFilter :: Int - , roles :: SnowflakeMap Role - , emojis :: SnowflakeMap Emoji - , features :: [Text] - , mfaLevel :: Int - , applicationID :: Maybe (Snowflake User) - , widgetEnabled :: Bool - , widgetChannelID :: Maybe (Snowflake GuildChannel) - , systemChannelID :: Maybe (Snowflake GuildChannel) - -- NOTE: Below are only sent on GuildCreate - , joinedAt :: Maybe UTCTime - , large :: Bool - , unavailable :: Bool - , memberCount :: Int - , voiceStates :: [VoiceState] - , members :: SnowflakeMap Member - , channels :: SnowflakeMap GuildChannel - , presences :: HashMap (Snowflake User) Presence - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Guild - deriving ( HasID Guild ) via HasIDField "id" Guild - -instance FromJSON Guild where - parseJSON = withObject "Guild" $ \v -> do - id <- v .: "id" - - members' <- do - members' <- v .: "members" - SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) members' - - channels' <- do - channels' <- v .: "channels" - SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) channels' - - presences' <- do - presences' <- v .: "presences" - LH.fromList <$> traverse (\m -> do - p <- parseJSON $ Object (m <> "guild_id" .= id) - pure (getID $ p ^. field @"user", p)) presences' - - Guild id - <$> v .: "name" - <*> v .: "icon" - <*> v .:? "splash" - <*> v .:? "owner" - <*> v .: "owner_id" - <*> v .:? "permissions" .!= 0 - <*> v .: "region" - <*> v .:? "afk_channel_id" - <*> v .: "afk_timeout" - <*> v .:? "embed_enabled" .!= False - <*> v .:? "embed_channel_id" - <*> v .: "verification_level" - <*> v .: "default_message_notifications" - <*> v .: "explicit_content_filter" - <*> v .: "roles" - <*> v .: "emojis" - <*> v .: "features" - <*> v .: "mfa_level" - <*> v .:? "application_id" - <*> v .:? "widget_enabled" .!= False - <*> v .:? "widget_channel_id" - <*> v .:? "system_channel_id" - <*> v .:? "joined_at" - <*> v .: "large" - <*> v .: "unavailable" - <*> v .: "member_count" - <*> v .: "voice_states" - <*> pure members' - <*> pure channels' - <*> pure presences' - -data instance Partial Guild = PartialGuild - { id :: Snowflake Guild - , name :: Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric (Partial Guild) - deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Guild) - deriving ( HasID Guild ) via HasIDField "id" (Partial Guild) - -data UpdatedGuild = UpdatedGuild - { id :: Snowflake Guild - , name :: Text - , icon :: Maybe Text - , splash :: Maybe Text - , owner :: Maybe Bool - , ownerID :: Snowflake User - , permissions :: Maybe Word64 - , region :: Text - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Int - , embedEnabled :: Maybe Bool - , embedChannelID :: Maybe (Snowflake GuildChannel) - , verificationLevel :: Int - , defaultMessageNotifications :: Int - , explicitContentFilter :: Int - , roles :: SnowflakeMap Role - , emojis :: SnowflakeMap Emoji - , features :: [Text] - , mfaLevel :: Int - , applicationID :: Maybe (Snowflake User) - , widgetEnabled :: Maybe Bool - , widgetChannelID :: Maybe (Snowflake GuildChannel) - , systemChannelID :: Maybe (Snowflake GuildChannel) - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UpdatedGuild - deriving ( FromJSON ) via CalamityJSON UpdatedGuild - deriving ( HasID Guild ) via HasIDField "id" UpdatedGuild diff --git a/src/Calamity/Types/Model/Guild/Guild.hs-boot b/src/Calamity/Types/Model/Guild/Guild.hs-boot deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Guild.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ --- | Discord Guilds -module Calamity.Types.Model.Guild.Guild - ( Guild - , UpdatedGuild ) where - -data Guild - -instance Show Guild -instance Eq Guild - -data UpdatedGuild - -instance Show UpdatedGuild -instance Eq UpdatedGuild diff --git a/src/Calamity/Types/Model/Guild/Invite.hs b/src/Calamity/Types/Model/Guild/Invite.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Invite.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | Guild invites -module Calamity.Types.Model.Guild.Invite - ( Invite(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Invite = Invite - { code :: Text - , guild :: Maybe (Partial Guild) - , channel :: Maybe (Partial Channel) - , targetUser :: Maybe (Snowflake User) - , targetUserType :: Maybe Int - , approximatePresenceCount :: Maybe Int - , approximateMemberCount :: Maybe Int - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Invite - deriving ( ToJSON ) via CalamityJSON Invite - deriving ( FromJSON ) via WithSpecialCases '["targetUser" `ExtractFieldFrom` "id"] Invite diff --git a/src/Calamity/Types/Model/Guild/Member.hs b/src/Calamity/Types/Model/Guild/Member.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Member.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | Guild Members -module Calamity.Types.Model.Guild.Member - ( Member(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Vector.Unboxing ( Vector ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG -import Data.Word (Word64) - -data Member = Member - { id :: Snowflake User - , username :: Text - , discriminator :: Text - , bot :: Maybe Bool - , avatar :: Maybe Text - , mfaEnabled :: Maybe Bool - , verified :: Maybe Bool - , email :: Maybe Text - , flags :: Maybe Word64 - , premiumType :: Maybe Word64 - , guildID :: Snowflake Guild - , nick :: Maybe Text - , roles :: Vector (Snowflake Role) - , joinedAt :: UTCTime - , deaf :: Bool - , mute :: Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Member - deriving ( FromJSON ) via WithSpecialCases '[ - "user" `ExtractFields` ["id", "username", "discriminator", - "bot", "avatar", "mfa_enabled", - "verified", "email", "flags", "premium_type"]] Member - deriving ( HasID Guild ) via HasIDField "guildID" Member - deriving ( HasID Member ) via HasIDFieldCoerce "id" Member User - deriving ( HasID User ) via HasIDField "id" Member diff --git a/src/Calamity/Types/Model/Guild/Member.hs-boot b/src/Calamity/Types/Model/Guild/Member.hs-boot deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Member.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ --- | Guild Members -module Calamity.Types.Model.Guild.Member - ( Member ) where - -data Member - -instance Show Member -instance Eq Member diff --git a/src/Calamity/Types/Model/Guild/Overwrite.hs b/src/Calamity/Types/Model/Guild/Overwrite.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Overwrite.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Permission overwrites -module Calamity.Types.Model.Guild.Overwrite - ( Overwrite(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Guild.Permissions -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Overwrite = Overwrite - { id :: Snowflake Overwrite - , type_ :: Text - , allow :: Permissions - , deny :: Permissions - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Overwrite - deriving ( ToJSON, FromJSON ) via CalamityJSON Overwrite - deriving ( HasID Overwrite ) via HasIDField "id" Overwrite diff --git a/src/Calamity/Types/Model/Guild/Permissions.hs b/src/Calamity/Types/Model/Guild/Permissions.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Permissions.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE NoDeriveAnyClass #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Guild permissions -module Calamity.Types.Model.Guild.Permissions - ( Permissions(..) - , createInstantInvite - , kickMembers - , banMembers - , administrator - , manageChannels - , manageGuild - , addReactions - , viewAuditLog - , prioritySpeaker - , stream - , viewChannel - , sendMessages - , sendTtsMessages - , manageMessages - , embedLinks - , attachFiles - , readMessageHistory - , mentionEveryone - , useExternalEmojis - , viewGuildInsights - , connect - , speak - , muteMembers - , deafenMembers - , moveMembers - , useVad - , changeNickname - , manageNicknames - , manageRoles - , manageWebhooks - , manageEmojis ) where - -import Data.Aeson ( FromJSON, ToJSON ) -import Data.Flags () -import Data.Flags.TH -import Data.Word - -import TextShow - -$(bitmaskWrapper "Permissions" ''Word64 [] - [ ("createInstantInvite", 0x00000001) - , ("kickMembers", 0x00000002) - , ("banMembers", 0x00000004) - , ("administrator", 0x00000008) - , ("manageChannels", 0x00000010) - , ("manageGuild", 0x00000020) - , ("addReactions", 0x00000040) - , ("viewAuditLog", 0x00000080) - , ("prioritySpeaker", 0x00000100) - , ("stream", 0x00000200) - , ("viewChannel", 0x00000400) - , ("sendMessages", 0x00000800) - , ("sendTtsMessages", 0x00001000) - , ("manageMessages", 0x00002000) - , ("embedLinks", 0x00004000) - , ("attachFiles", 0x00008000) - , ("readMessageHistory", 0x00010000) - , ("mentionEveryone", 0x00020000) - , ("useExternalEmojis", 0x00040000) - , ("viewGuildInsights", 0x00080000) - , ("connect", 0x00100000) - , ("speak", 0x00200000) - , ("muteMembers", 0x00400000) - , ("deafenMembers", 0x00800000) - , ("moveMembers", 0x01000000) - , ("useVad", 0x02000000) - , ("changeNickname", 0x04000000) - , ("manageNicknames", 0x08000000) - , ("manageRoles", 0x10000000) - , ("manageWebhooks", 0x20000000) - , ("manageEmojis", 0x4000000)]) - -deriving via Word64 instance ToJSON Permissions - -deriving via Word64 instance FromJSON Permissions - -deriving via FromStringShow Permissions instance TextShow Permissions diff --git a/src/Calamity/Types/Model/Guild/Role.hs b/src/Calamity/Types/Model/Guild/Role.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/Role.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | Guild roles -module Calamity.Types.Model.Guild.Role - ( Role(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.IntColour () -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild.Permissions -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Colour -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Role = Role - { id :: Snowflake Role - , name :: Text - , color :: Colour Double - , hoist :: Bool - , position :: Int - , permissions :: Permissions - , managed :: Bool - , mentionable :: Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Role - deriving ( ToJSON, FromJSON ) via CalamityJSON Role - deriving ( HasID Role ) via HasIDField "id" Role diff --git a/src/Calamity/Types/Model/Guild/UnavailableGuild.hs b/src/Calamity/Types/Model/Guild/UnavailableGuild.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Guild/UnavailableGuild.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | Guilds that are unavailable -module Calamity.Types.Model.Guild.UnavailableGuild - ( UnavailableGuild(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Guild.Guild -import Calamity.Types.Snowflake - -import Data.Aeson - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data UnavailableGuild = UnavailableGuild - { id :: Snowflake Guild - , unavailable :: Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UnavailableGuild - deriving ( ToJSON, FromJSON ) via CalamityJSON UnavailableGuild - deriving ( HasID Guild ) via HasIDField "id" UnavailableGuild diff --git a/src/Calamity/Types/Model/Presence.hs b/src/Calamity/Types/Model/Presence.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Presence.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | User presences -module Calamity.Types.Model.Presence - ( module Calamity.Types.Model.Presence.Presence - , module Calamity.Types.Model.Presence.Activity ) where - -import Calamity.Types.Model.Presence.Activity -import Calamity.Types.Model.Presence.Presence diff --git a/src/Calamity/Types/Model/Presence/Activity.hs b/src/Calamity/Types/Model/Presence/Activity.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Presence/Activity.hs +++ /dev/null @@ -1,131 +0,0 @@ --- | User activities -module Calamity.Types.Model.Presence.Activity - ( Activity(..) - , activity - , ActivityType(..) - , ActivityTimestamps(..) - , ActivityParty(..) - , ActivityAssets(..) - , ActivitySecrets(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils -import Calamity.Types.Snowflake -import Calamity.Types.UnixTimestamp - -import Data.Aeson -import Data.Scientific -import Data.Text.Lazy ( Text ) -import Data.Word - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data ActivityType - = Game - | Streaming - | Listening - | Custom - | Other Int - deriving ( Eq, Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric ActivityType - -instance ToJSON ActivityType where - toJSON Game = Number 0 - toJSON Streaming = Number 1 - toJSON Listening = Number 2 - toJSON (Other n) = Number $ fromIntegral n - toJSON Custom = Number 4 - -instance FromJSON ActivityType where - parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of - 0 -> pure Game - 1 -> pure Streaming - 2 -> pure Listening - 4 -> pure Custom - n -> pure $ Other n - Nothing -> fail $ "Invalid ActivityType: " <> show n - -data Activity = Activity - { name :: Text - , type_ :: ActivityType - , url :: Maybe Text - , timestamps :: Maybe ActivityTimestamps - , applicationID :: Maybe (Snowflake ()) - , details :: Maybe Text - , state :: Maybe Text - , party :: Maybe ActivityParty - , assets :: Maybe ActivityAssets - , secrets :: Maybe ActivitySecrets - , instance_ :: Maybe Bool - , flags :: Maybe Word64 - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Activity - deriving ( ToJSON, FromJSON ) via CalamityJSON Activity - --- | Make an 'Activity' with all optional fields set to Nothing -activity :: Text -> ActivityType -> Activity -activity name type_ = - Activity - { name = name, - type_ = type_, - url = Nothing, - timestamps = Nothing, - applicationID = Nothing, - details = Nothing, - state = Nothing, - party = Nothing, - assets = Nothing, - secrets = Nothing, - instance_ = Nothing, - flags = Nothing - } - -data ActivityTimestamps = ActivityTimestamps - { start :: Maybe UnixTimestamp - , end :: Maybe UnixTimestamp - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivityTimestamps - -instance ToJSON ActivityTimestamps where - toJSON ActivityTimestamps { start, end } = object - ["start" .= (unixToMilliseconds <$> start), "end" .= (unixToMilliseconds <$> end)] - -instance FromJSON ActivityTimestamps where - parseJSON = withObject "ActivityTimestamps" $ \v -> do - start <- millisecondsToUnix <<$>> v .:? "start" - end <- millisecondsToUnix <<$>> v .:? "end" - - pure $ ActivityTimestamps start end - -data ActivityParty = ActivityParty - { id :: Maybe Text - , size :: Maybe (Int, Int) - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivityParty - deriving ( ToJSON, FromJSON ) via CalamityJSON ActivityParty - -data ActivityAssets = ActivityAssets - { largeImage :: Maybe Text - , largeText :: Maybe Text - , smallImage :: Maybe Text - , smallText :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivityAssets - deriving ( ToJSON, FromJSON ) via CalamityJSON ActivityAssets - -data ActivitySecrets = ActivitySecrets - { join :: Maybe Text - , spectate :: Maybe Text - , match :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivitySecrets - deriving ( ToJSON, FromJSON ) via CalamityJSON ActivitySecrets diff --git a/src/Calamity/Types/Model/Presence/Presence.hs b/src/Calamity/Types/Model/Presence/Presence.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Presence/Presence.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | User presences -module Calamity.Types.Model.Presence.Presence - ( Presence(..) - , ClientStatus(..) ) where - -import Calamity.Internal.AesonThings -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Presence.Activity -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import qualified Data.Override as O -import Data.Override.Aeson () -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Presence = Presence - { user :: Snowflake User - , game :: Maybe Activity - , guildID :: Snowflake Guild - , status :: StatusType - , clientStatus :: ClientStatus - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Presence - deriving ( ToJSON, FromJSON ) via CalamityJSON - (O.Override Presence '["user" `O.As` Partial User]) - deriving ( HasID User ) via HasIDField "user" Presence - deriving ( HasID Guild ) via HasIDField "guildID" Presence - -data ClientStatus = ClientStatus - { desktop :: Maybe Text - , mobile :: Maybe Text - , web :: Maybe Text - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ClientStatus - deriving ( ToJSON, FromJSON ) via CalamityJSON ClientStatus diff --git a/src/Calamity/Types/Model/User.hs b/src/Calamity/Types/Model/User.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/User.hs +++ /dev/null @@ -1,70 +0,0 @@ --- | A User -module Calamity.Types.Model.User - ( User(..) - , Partial(PartialUser) - , StatusType(..) ) where - -import Calamity.Internal.AesonThings -import {-# SOURCE #-} Calamity.Types.Model.Guild.Member -import Calamity.Types.Partial -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Word - -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG - -data User = User - { id :: Snowflake User - , username :: Text - , discriminator :: Text - , bot :: Maybe Bool - , avatar :: Maybe Text - , mfaEnabled :: Maybe Bool - , verified :: Maybe Bool - , email :: Maybe Text - , flags :: Maybe Word64 - , premiumType :: Maybe Word64 - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric User - deriving ( ToJSON, FromJSON ) via CalamityJSON User - deriving ( HasID User ) via HasIDField "id" User - deriving ( HasID Member ) via HasIDFieldCoerce' "id" User - -newtype instance Partial User = PartialUser - { id :: Snowflake User - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric (Partial User) - deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial User) - deriving ( HasID User ) via HasIDField "id" (Partial User) - -data StatusType - = Idle - | DND - | Online - | Offline - | Invisible - deriving ( Eq, Show, Enum, Generic ) - deriving ( TextShow ) via TSG.FromGeneric StatusType - -instance FromJSON StatusType where - parseJSON = withText "StatusType" $ \case - "idle" -> pure Idle - "dnd" -> pure DND - "online" -> pure Online - "offline" -> pure Offline - "invisible" -> pure Invisible - _ -> fail "Unknown status type" - -instance ToJSON StatusType where - toJSON = String . \case - Idle -> "idle" - DND -> "dnd" - Online -> "online" - Offline -> "offline" - Invisible -> "invisible" diff --git a/src/Calamity/Types/Model/Voice.hs b/src/Calamity/Types/Model/Voice.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Voice.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | Voice data types -module Calamity.Types.Model.Voice - ( module Calamity.Types.Model.Voice.VoiceState - , module Calamity.Types.Model.Voice.VoiceRegion ) where - -import Calamity.Types.Model.Voice.VoiceRegion -import Calamity.Types.Model.Voice.VoiceState diff --git a/src/Calamity/Types/Model/Voice/VoiceRegion.hs b/src/Calamity/Types/Model/Voice/VoiceRegion.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Voice/VoiceRegion.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Voice regions -module Calamity.Types.Model.Voice.VoiceRegion - ( VoiceRegion(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data VoiceRegion = VoiceRegion - { id :: Snowflake VoiceRegion - , name :: Text - , vip :: Bool - , optimal :: Bool - , deprecated :: Bool - , custom :: Bool - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric VoiceRegion - deriving ( ToJSON, FromJSON ) via CalamityJSON VoiceRegion diff --git a/src/Calamity/Types/Model/Voice/VoiceState.hs b/src/Calamity/Types/Model/Voice/VoiceState.hs deleted file mode 100644 --- a/src/Calamity/Types/Model/Voice/VoiceState.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Calamity.Types.Model.Voice.VoiceState - ( VoiceState(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel.Guild.Voice -import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data VoiceState = VoiceState - { guildID :: Maybe (Snowflake Guild) - , channelID :: Maybe (Snowflake VoiceChannel) - , userID :: Snowflake User - , sessionID :: Text - , deaf :: Bool - , mute :: Bool - , selfDeaf :: Bool - , selfMute :: Bool - , suppress :: Bool - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric VoiceState - deriving ( ToJSON, FromJSON ) via CalamityJSON VoiceState diff --git a/src/Calamity/Types/Partial.hs b/src/Calamity/Types/Partial.hs deleted file mode 100644 --- a/src/Calamity/Types/Partial.hs +++ /dev/null @@ -1,5 +0,0 @@ --- | Partial data family -module Calamity.Types.Partial - ( Partial ) where - -data family Partial t diff --git a/src/Calamity/Types/Snowflake.hs b/src/Calamity/Types/Snowflake.hs deleted file mode 100644 --- a/src/Calamity/Types/Snowflake.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | The snowflake type -module Calamity.Types.Snowflake - ( Snowflake(..) - , HasID(..) - , type HasID' - , HasIDField(..) - , HasIDFieldCoerce(..) - , type HasIDFieldCoerce' - , coerceSnowflake ) where - -import Control.DeepSeq -import Control.Lens - -import Data.Aeson -import Data.Data -import Data.Generics.Product.Fields -import Data.Hashable -import Data.Kind -import Data.Text.Read -import qualified Data.Vector.Unboxing as U -import Data.Word - -import GHC.Generics - -import TextShow - --- Thanks sbrg --- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78 -newtype Snowflake (t :: Type) = Snowflake - { fromSnowflake :: Word64 - } - deriving ( Generic, Eq, Ord, Data ) - deriving ( Show, TextShow ) via Word64 - deriving newtype ( NFData, ToJSONKey, Hashable, U.Unboxable ) - -instance ToJSON (Snowflake t) where - toJSON (Snowflake s) = String . showt $ s - -instance FromJSON (Snowflake t) where - parseJSON = withText "Snowflake" $ \t -> do - n <- case decimal t of - Right (n, _) -> pure n - Left e -> fail e - pure $ Snowflake n - -coerceSnowflake :: Snowflake a -> Snowflake b -coerceSnowflake (Snowflake t) = Snowflake t - --- | A typeclass for types that contain snowflakes of type `b` -class HasID b a where - - -- | Retrieve the ID from the type - getID :: a -> Snowflake b - -type HasID' a = HasID a a - --- | A newtype wrapper for deriving HasID generically -newtype HasIDField field a = HasIDField a - -instance (HasID b c, HasField' field a c) => HasID b (HasIDField field a) where - getID (HasIDField a) = getID $ a ^. field' @field - --- | A data `a` which contains an ID of type `Snowflake c` --- which should be swapped with `Snowflake b` upon fetching -newtype HasIDFieldCoerce field a c = HasIDFieldCoerce a - -type HasIDFieldCoerce' field a = HasIDFieldCoerce field a a - -instance (HasID c d, HasField' field a d) => HasID b (HasIDFieldCoerce field a c) where - getID (HasIDFieldCoerce a) = coerceSnowflake . getID @c $ a ^. field' @field - -instance HasID a (Snowflake a) where - getID = id diff --git a/src/Calamity/Types/Tellable.hs b/src/Calamity/Types/Tellable.hs deleted file mode 100644 --- a/src/Calamity/Types/Tellable.hs +++ /dev/null @@ -1,155 +0,0 @@ --- | Things that are messageable -module Calamity.Types.Tellable - ( ToMessage(..) - , Tellable(..) - , TFile(..) - , TMention(..) - , tell ) where - -import Calamity.Client.Types -import Calamity.HTTP -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Control.Lens - -import Data.ByteString.Lazy ( ByteString ) -import Data.Default.Class -import Data.Monoid -import qualified Data.Text as S -import qualified Data.Text.Lazy as L - -import GHC.Generics - -import qualified Polysemy as P -import qualified Polysemy.Error as P - --- | A wrapper type for sending files -data TFile = TFile - S.Text -- ^ The filename - ByteString -- ^ The content - deriving ( Show, Generic ) - --- | A wrapper type for allowing mentions -newtype TMention a = TMention (Snowflake a) - deriving ( Show, Generic ) - --- | Things that can be used to send a message --- --- Can be used to compose text, embeds, and files. /e.g./ --- --- @ --- 'intoMsg' @'L.Text' "A message" '<>' 'intoMsg' @'Embed' ('def' '&' #description '?~' "Embed description") --- @ -class ToMessage a where - -- | Turn @a@ into a 'CreateMessageOptions' builder - intoMsg :: a -> Endo CreateMessageOptions - --- | Message content, '(<>)' concatenates the content -instance ToMessage L.Text where - intoMsg t = Endo (#content %~ (<> Just (L.toStrict t))) - --- | Message content, '(<>)' concatenates the content -instance ToMessage S.Text where - intoMsg t = Endo (#content %~ (<> Just t)) - --- | Message content, '(<>)' concatenates the content -instance ToMessage String where - intoMsg t = Endo (#content %~ (<> Just (S.pack t))) - --- | Message embed, '(<>)' merges embeds using '(<>)' -instance ToMessage Embed where - intoMsg e = Endo (#embed %~ (<> Just e)) - --- | Message file, '(<>)' keeps the last added file -instance ToMessage TFile where - intoMsg (TFile n f) = Endo (#file %~ getLast . (<> Last (Just (n, f))) . Last) - --- | Allowed mentions, '(<>)' combines allowed mentions -instance ToMessage AllowedMentions where - intoMsg m = Endo (#allowedMentions %~ (<> Just m)) - --- | Add a 'User' id to the list of allowed user mentions -instance ToMessage (TMention User) where - intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [s]) - --- | Add a 'Member' id to the list of allowed user mentions -instance ToMessage (TMention Member) where - intoMsg (TMention s) = intoMsg (def @AllowedMentions & #users <>~ [coerceSnowflake s]) - --- | Add a 'Role' id to the list of allowed role mentions -instance ToMessage (TMention Role) where - intoMsg (TMention s) = intoMsg (def @AllowedMentions & #roles <>~ [s]) - -instance ToMessage (Endo CreateMessageOptions) where - intoMsg = Prelude.id - -instance ToMessage (CreateMessageOptions -> CreateMessageOptions) where - intoMsg = Endo - -instance ToMessage CreateMessageOptions where - intoMsg = Endo . const - -class Tellable a where - getChannel :: (BotC r, P.Member (P.Error RestError) r) => a -> P.Sem r (Snowflake Channel) - -runToMessage :: ToMessage a => a -> CreateMessageOptions -runToMessage = flip appEndo def . intoMsg - --- | Send a message to something that is messageable --- --- To send a string literal you'll probably want to use @TypeApplication@ to --- specify the type of @msg@ --- --- ==== Examples --- --- Sending a string: --- --- @ --- 'void' $ 'tell' @'Text' m ("Somebody told me to tell you about: " '<>' s) --- @ -tell :: forall msg r t. (BotC r, ToMessage msg, Tellable t) => t -> msg -> P.Sem r (Either RestError Message) -tell target (runToMessage -> msg) = P.runError $ do - cid <- getChannel target - r <- invoke $ CreateMessage cid msg - P.fromEither r - -instance Tellable DMChannel where - getChannel = pure . getID - -instance Tellable (Snowflake Channel) where - getChannel = pure - -instance Tellable Channel where - getChannel = pure . getID - -instance Tellable (Snowflake DMChannel) where - getChannel = pure . coerceSnowflake - -instance Tellable TextChannel where - getChannel = pure . getID - -instance Tellable (Snowflake TextChannel) where - getChannel = pure . coerceSnowflake - -instance Tellable Message where - getChannel = pure . getID - -messageUser :: (BotC r, P.Member (P.Error RestError) r, HasID User a) => a -> P.Sem r (Snowflake Channel) -messageUser (getID @User -> uid) = do - c <- invoke $ CreateDM uid - getID <$> P.fromEither c - -instance Tellable (Snowflake Member) where - getChannel = messageUser . coerceSnowflake @_ @User - -instance Tellable Member where - getChannel = messageUser - -instance Tellable User where - getChannel = messageUser - -instance Tellable (Snowflake User) where - getChannel = messageUser diff --git a/src/Calamity/Types/Token.hs b/src/Calamity/Types/Token.hs deleted file mode 100644 --- a/src/Calamity/Types/Token.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Discord tokens -module Calamity.Types.Token - ( Token(..) - , formatToken - , rawToken ) where - -import Data.Text.Lazy - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -data Token - = BotToken Text - | UserToken Text - deriving ( Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric Token - -formatToken :: Token -> Text -formatToken (BotToken t) = "Bot " <> t -formatToken (UserToken t) = t - -rawToken :: Token -> Text -rawToken (BotToken t) = t -rawToken (UserToken t) = t diff --git a/src/Calamity/Types/UnixTimestamp.hs b/src/Calamity/Types/UnixTimestamp.hs deleted file mode 100644 --- a/src/Calamity/Types/UnixTimestamp.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | Parsing of unix timestamps -module Calamity.Types.UnixTimestamp - ( UnixTimestamp(..) - , unixToMilliseconds - , millisecondsToUnix ) where - -import Calamity.Internal.Utils () - -import Control.Arrow - -import Data.Aeson -import Data.Aeson.Encoding ( word64 ) -import Data.Time -import Data.Time.Clock.POSIX -import Data.Word - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -newtype UnixTimestamp = UnixTimestamp - { unUnixTimestamp :: UTCTime - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UnixTimestamp - -unixToMilliseconds :: UnixTimestamp -> Word64 -unixToMilliseconds = unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> (* 1000) - >>> round - -millisecondsToUnix :: Word64 -> UnixTimestamp -millisecondsToUnix = toRational - >>> fromRational - >>> (/ 1000) - >>> posixSecondsToUTCTime - >>> UnixTimestamp - -instance ToJSON UnixTimestamp where - 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 diff --git a/src/Calamity/Types/Upgradeable.hs b/src/Calamity/Types/Upgradeable.hs deleted file mode 100644 --- a/src/Calamity/Types/Upgradeable.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Things that can be upgraded from snowflakes to their full data -module Calamity.Types.Upgradeable - ( Upgradeable(..) ) where - -import Calamity.Cache.Eff -import Calamity.Client.Types -import Calamity.HTTP as H -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 Control.Lens - -import Data.Generics.Sum.Constructors - -import qualified Polysemy as P -import qualified Polysemy.Fail as P -import qualified Polysemy.NonDet as P - --- | 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 it's complete data. - -- - -- If it existed in the cache then it is returned from there, otherwise we - -- fetch from HTTP and update the cache on success. - upgrade :: BotC r => ids -> P.Sem r (Maybe a) - -maybeToAlt :: Alternative f => Maybe a -> f a -maybeToAlt (Just x) = pure x -maybeToAlt Nothing = empty - -instance Upgradeable User (Snowflake User) where - upgrade uid = P.runNonDetMaybe ((getUser uid >>= maybeToAlt) <|> gethttp) - where - gethttp = P.failToNonDet $ do - Right u <- invoke $ H.GetUser uid - setUser u - pure u - -instance Upgradeable Member (Snowflake Guild, Snowflake Member) where - upgrade (gid, mid) = P.runNonDetMaybe (getcache <|> gethttp) - where - getcache = P.failToNonDet $ do - Just g <- getGuild gid - Just m <- pure (g ^. #members . at mid) - pure m - gethttp = P.failToNonDet $ do - Right m <- invoke $ H.GetGuildMember gid (coerceSnowflake @_ @User mid) - -- getcache could have failed becuase the member wasn't cached - updateGuild gid (#members . at mid ?~ m) - pure m - -instance Upgradeable Guild (Snowflake Guild) where - upgrade gid = P.runNonDetMaybe ((getGuild gid >>= maybeToAlt) <|> gethttp) - where - gethttp = P.failToNonDet $ do - Right g <- invoke $ H.GetGuild gid - pure g - -insertChannel :: BotC r => Channel -> P.Sem r () -insertChannel (DMChannel' dm) = setDM dm -insertChannel (GuildChannel' ch) = - updateGuild (getID ch) (#channels . at (getID @GuildChannel ch) ?~ ch) -insertChannel _ = pure () - -instance Upgradeable Channel (Snowflake Channel) where - upgrade cid = P.runNonDetMaybe (getcacheDM <|> getcacheGuild <|> gethttp) - where - getcacheDM = DMChannel' <<$>> getDM (coerceSnowflake cid) >>= maybeToAlt - getcacheGuild = GuildChannel' <<$>> getGuildChannel (coerceSnowflake cid) >>= maybeToAlt - gethttp = P.failToNonDet $ do - Right c <- invoke $ H.GetChannel cid - insertChannel c - pure c - -instance Upgradeable GuildChannel (Snowflake GuildChannel) where - upgrade cid = P.runNonDetMaybe (getcache <|> gethttp) - where - getcache = getGuildChannel (coerceSnowflake cid) >>= maybeToAlt - gethttp = P.failToNonDet $ do - Right c <- invoke $ H.GetChannel (coerceSnowflake @_ @Channel cid) - insertChannel c - maybeToAlt (c ^? _Ctor @"GuildChannel'") - -instance Upgradeable Emoji (Snowflake Guild, Snowflake Emoji) where - upgrade (gid, eid) = P.runNonDetMaybe (getcache <|> gethttp) - where - getcache = P.failToNonDet $ do - Just g <- getGuild gid - Just m <- pure (g ^. #emojis . at eid) - pure m - gethttp = P.failToNonDet $ do - Right e <- invoke $ H.GetGuildEmoji gid eid - updateGuild gid (#emojis . at eid ?~ e) - pure e diff --git a/src/Calamity/Utils.hs b/src/Calamity/Utils.hs deleted file mode 100644 --- a/src/Calamity/Utils.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | Useful things -module Calamity.Utils - ( module Calamity.Utils.Permissions - , module Calamity.Utils.Message - , module Calamity.Utils.Colour ) where - -import Calamity.Utils.Colour -import Calamity.Utils.Message -import Calamity.Utils.Permissions diff --git a/src/Calamity/Utils/Colour.hs b/src/Calamity/Utils/Colour.hs deleted file mode 100644 --- a/src/Calamity/Utils/Colour.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | Discord colour utilities -module Calamity.Utils.Colour - ( colourToWord64 - , colourFromWord64 - -- * Useful colours - , blurple - , greyple ) where - -import Calamity.Internal.IntColour - -import Data.Colour -import Data.Colour.SRGB ( sRGB24 ) - -blurple :: (Ord a, Floating a) => Colour a -blurple = sRGB24 0x72 0x89 0xda - -greyple :: (Ord a, Floating a) => Colour a -greyple = sRGB24 0x99 0xaa 0xb5 diff --git a/src/Calamity/Utils/Message.hs b/src/Calamity/Utils/Message.hs deleted file mode 100644 --- a/src/Calamity/Utils/Message.hs +++ /dev/null @@ -1,197 +0,0 @@ --- | Things for formatting things -module Calamity.Utils.Message - ( codeblock, - codeblock', - codeline, - escapeCodeblocks, - escapeCodelines, - escapeBold, - escapeStrike, - escapeUnderline, - escapeSpoilers, - escapeFormatting, - bold, - strike, - underline, - quote, - quoteAll, - spoiler, - zws, - fmtEmoji, - displayUser, - Mentionable (..), - ) -where - -import Calamity.Types.Model.Channel (Category, Channel, DMChannel, GuildChannel, TextChannel, VoiceChannel) -import Calamity.Types.Model.Guild (Emoji(..), Member, Role) -import Calamity.Types.Model.User (User) -import Calamity.Types.Snowflake -import Control.Lens -import Data.Generics.Product.Fields -import Data.Maybe (fromMaybe) -import Data.String (IsString, fromString) -import qualified Data.Text.Lazy as L -import TextShow (TextShow (showtl)) -import Data.Foldable (Foldable(foldl')) - -zws :: IsString s => s -zws = fromString "\x200b" - --- | Replaces all occurences of @\`\`\`@ with @\`\\`\\`@ -escapeCodeblocks :: L.Text -> L.Text -escapeCodeblocks = L.replace "```" (L.intercalate zws $ replicate 3 "`") - --- | Replaces all occurences of @\`\`@ with @\`\\`@ -escapeCodelines :: L.Text -> L.Text -escapeCodelines = L.replace "``" (L.intercalate zws $ replicate 2 "`") - --- | Replaces all occurences of @\*\*@ with @\*\\*@ -escapeBold :: L.Text -> L.Text -escapeBold = L.replace "**" (L.intercalate zws $ replicate 2 "*") - --- | Replaces all occurences of @\~\~@ with @\~\\~@ -escapeStrike :: L.Text -> L.Text -escapeStrike = L.replace "~~" (L.intercalate zws $ replicate 2 "~") - --- | Replaces all occurences of @\_\_@ with @\_\\_@ -escapeUnderline :: L.Text -> L.Text -escapeUnderline = L.replace "__" (L.intercalate zws $ replicate 2 "_") - --- | Replaces all occurences of @\|\|@ with @\|\\|@ -escapeSpoilers :: L.Text -> L.Text -escapeSpoilers = L.replace "||" (L.intercalate zws $ replicate 2 "|") - --- | Escape all discord formatting -escapeFormatting :: L.Text -> L.Text -escapeFormatting = foldl' (.) Prelude.id [escapeCodelines, escapeCodeblocks, escapeBold, escapeStrike, escapeUnderline, escapeSpoilers, escapeFormatting] - --- | Formats a lang and content into a codeblock --- --- >>> codeblock "hs" "x = y" --- "```hs\nx = y\n```" --- --- Any codeblocks in the @content@ are escaped -codeblock :: L.Text -- ^ language - -> L.Text -- ^ content - -> L.Text -codeblock lang = codeblock' (Just lang) - --- | Formats an optional lang and content into a codeblock --- --- Any codeblocks in the @content@ are escaped -codeblock' :: Maybe L.Text -- ^ language - -> L.Text -- ^ content - -> L.Text -codeblock' lang content = "```" <> fromMaybe "" lang <> "\n" <> - escapeCodeblocks content <> - "\n```" - --- | Formats some content into a code line --- --- This always uses @``@ code lines as they can be escaped --- --- Any code lines in the content are escaped -codeline :: L.Text -> L.Text -codeline content = "``" <> escapeCodelines content <> "``" - --- | Formats some text into it's bolded form --- --- Any existing bolded text is escaped -bold :: L.Text -> L.Text -bold content = "**" <> escapeBold content <> "**" - --- | Formats some text into it's striked form --- --- Any existing striked text is escaped -strike :: L.Text -> L.Text -strike content = "~~" <> escapeStrike content <> "~~" - --- | Formats some text into it's underlined form --- --- Any existing underlined text is escaped -underline :: L.Text -> L.Text -underline content = "__" <> escapeUnderline content <> "__" - --- | Quotes a section of text -quote :: L.Text -> L.Text -quote = ("> " <>) - --- | Quotes all remaining text -quoteAll :: L.Text -> L.Text -quoteAll = (">> " <>) - --- | Formats some text into it's spoilered form --- --- Any existing spoilers are escaped -spoiler :: L.Text -> L.Text -spoiler content = "||" <> escapeSpoilers content <> "||" - -fmtEmoji :: Emoji -> L.Text -fmtEmoji Emoji { id, name, animated } = "<" <> ifanim <> ":" <> name <> ":" <> showtl id <> ">" - where ifanim = if animated then "a" else "" - --- | Format a 'User' or 'Member' into the format of @username#discriminator@ -displayUser :: (HasField' "username" a L.Text, HasField' "discriminator" a L.Text) => a -> L.Text -displayUser u = (u ^. field' @"username") <> "#" <> (u ^. field' @"discriminator") - -mentionSnowflake :: L.Text -> Snowflake a -> L.Text -mentionSnowflake tag s = "<" <> tag <> showtl s <> ">" - --- | Things that can be mentioned -class Mentionable a where - mention :: a -> L.Text - -instance Mentionable (Snowflake User) where - mention = mentionSnowflake "@" - -instance Mentionable (Snowflake Member) where - mention = mentionSnowflake "@" - -instance Mentionable (Snowflake Channel) where - mention = mentionSnowflake "#" - -instance Mentionable (Snowflake TextChannel) where - mention = mentionSnowflake "#" - -instance Mentionable (Snowflake VoiceChannel) where - mention = mentionSnowflake "#" - -instance Mentionable (Snowflake Category) where - mention = mentionSnowflake "#" - -instance Mentionable (Snowflake GuildChannel) where - mention = mentionSnowflake "#" - -instance Mentionable (Snowflake DMChannel) where - mention = mentionSnowflake "#" - -instance Mentionable (Snowflake Role) where - mention = mentionSnowflake "@&" - -instance Mentionable User where - mention = mentionSnowflake "@" . getID @User - -instance Mentionable Member where - mention = mentionSnowflake "@" . getID @Member - -instance Mentionable Channel where - mention = mentionSnowflake "#" . getID @Channel - -instance Mentionable TextChannel where - mention = mentionSnowflake "#" . getID @TextChannel - -instance Mentionable VoiceChannel where - mention = mentionSnowflake "#" . getID @VoiceChannel - -instance Mentionable Category where - mention = mentionSnowflake "#" . getID @Category - -instance Mentionable GuildChannel where - mention = mentionSnowflake "#" . getID @GuildChannel - -instance Mentionable DMChannel where - mention = mentionSnowflake "#" . getID @DMChannel - -instance Mentionable Role where - mention = mentionSnowflake "@&" . getID @Role diff --git a/src/Calamity/Utils/Permissions.hs b/src/Calamity/Utils/Permissions.hs deleted file mode 100644 --- a/src/Calamity/Utils/Permissions.hs +++ /dev/null @@ -1,118 +0,0 @@ --- | Permission utilities -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 Control.Lens - -import Data.Flags -import qualified Data.Vector.Unboxing as V - -import qualified Polysemy as P -import Data.Foldable (Foldable(foldl')) - --- | 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 - rolePerms = g ^.. #roles . foldMap ix (V.toList $ m ^. #roles) . #permissions - perms = foldl' andFlags noFlags (permsEveryone:rolePerms) - in if perms .<=. administrator - then allFlags - else perms - --- | Apply any 'Overwrite's for a 'GuildChannel' onto some 'Permissions' -applyOverwrites :: GuildChannel -> Member -> Permissions -> Permissions -applyOverwrites c m p - | p .<=. administrator = allFlags - | otherwise = - let everyoneOverwrite = c ^. #permissionOverwrites . at (coerceSnowflake $ getID @Guild c) - everyoneAllow = maybe noFlags (^. #allow) everyoneOverwrite - everyoneDeny = maybe noFlags (^. #deny) everyoneOverwrite - p' = p .-. everyoneDeny .+. everyoneAllow - roleOverwrites = c ^.. #permissionOverwrites . foldMap ix - (map (coerceSnowflake @_ @Overwrite) . V.toList $ m ^. #roles) - roleAllow = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #allow) - roleDeny = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #deny) - p'' = p' .-. roleDeny .+. roleAllow - memberOverwrite = c ^. #permissionOverwrites . 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 - -- | Calculate a 'Member'\'s 'Permissions' in something - permissionsIn :: a -> Member -> Permissions - --- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites -instance PermissionsIn (Guild, GuildChannel) where - permissionsIn (g, c) m = applyOverwrites c m $ basePermissions g m - --- | A 'Member'\'s 'Permissions' in a guild are just their roles -instance PermissionsIn Guild where - permissionsIn g m = basePermissions g m - --- | A variant of 'PermissionsIn' that will use the cache/http. -class PermissionsIn' a where - -- | Calculate the permissions of something that has a 'User' id - -- - -- If permissions could not be calculated because something couldn't be found - -- in the cache, this will return an empty set of permissions. Use - -- 'permissionsIn' if you want to handle cases where something might not exist - -- in cache. - 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 -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 - --- | A 'Member'\'s 'Permissions' in a guild are just their roles -instance PermissionsIn' Guild where - permissionsIn' g (getID @User -> uid) = do - m <- upgrade (getID @Guild g, coerceSnowflake @_ @Member uid) - case m of - 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 -instance PermissionsIn' (Snowflake GuildChannel) where - permissionsIn' cid u = do - c <- upgrade cid - case c of - 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 -instance PermissionsIn' (Snowflake Guild) where - permissionsIn' gid u = do - g <- upgrade gid - case g of - Just g' -> permissionsIn' g' u - Nothing -> pure noFlags