diff options
Diffstat (limited to 'deps/discord-haskell/src')
36 files changed, 8525 insertions, 0 deletions
diff --git a/deps/discord-haskell/src/Discord.hs b/deps/discord-haskell/src/Discord.hs new file mode 100644 index 0000000..5ed8bcf --- /dev/null +++ b/deps/discord-haskell/src/Discord.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Main module of the library +-- Contains all the entrypoints +module Discord + ( runDiscord + , restCall + , sendCommand + , readCache + , stopDiscord + , getGatewayLatency + , measureLatency + + , DiscordHandler + + , DiscordHandle + , Cache(..) + , RestCallErrorCode(..) + , RunDiscordOpts(..) + , FromJSON + , Request + , def + ) where + +import Prelude hiding (log) +import Control.Exception (Exception) +import Control.Monad.Reader (ReaderT, runReaderT, void, ask, liftIO, forever, asks) +import Data.Aeson (FromJSON) +import Data.Default (Default, def) +import Data.IORef (writeIORef) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) + +import UnliftIO (race, try, finally, SomeException, IOException, readIORef) +import UnliftIO.Concurrent + +import Discord.Handle +import Discord.Internal.Rest +import Discord.Internal.Rest.User (UserRequest(GetCurrentUser)) +import Discord.Internal.Gateway + +-- | A `ReaderT` wrapper around `DiscordHandle` and `IO`. Most functions act in +-- this monad +type DiscordHandler = ReaderT DiscordHandle IO + +-- | Options for the connection. +data RunDiscordOpts = RunDiscordOpts + { -- | Token for the discord API + discordToken :: T.Text + , -- | Actions executed right after a connexion to discord's API is + -- established + discordOnStart :: DiscordHandler () + , -- | Actions executed at termination. + -- + -- Note that this runs in plain `IO` and not in `DiscordHandler` as the + -- connexion has been closed before this runs. + -- + -- Useful for cleaning up. + discordOnEnd :: IO () + , -- | Actions run upon the reception of an `Event`. This is here most of the + -- code of the bot may get dispatched from. + discordOnEvent :: Event -> DiscordHandler () + , -- | Dispatching on internal logs + discordOnLog :: T.Text -> IO () + , -- | Fork a thread for every `Event` recived + discordForkThreadForEvents :: Bool + , -- | The gateway intents the bot is asking for + discordGatewayIntent :: GatewayIntent + , -- | Whether to use the cache (may use a lot of memory, only enable if it will be used!) + discordEnableCache :: Bool + } + +-- | Default values for `RunDiscordOpts` +instance Default RunDiscordOpts where + def = RunDiscordOpts { discordToken = "" + , discordOnStart = pure () + , discordOnEnd = pure () + , discordOnEvent = \_ -> pure () + , discordOnLog = \_ -> pure () + , discordForkThreadForEvents = True + , discordGatewayIntent = def + , discordEnableCache = False + } + +-- | Entrypoint to the library +runDiscord :: RunDiscordOpts -> IO T.Text +runDiscord opts = do + log <- newChan + logId <- liftIO $ startLogger (discordOnLog opts) log + (cache, cacheId) <- liftIO $ startCacheThread (discordEnableCache opts) log + (rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log + (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) (discordGatewayIntent opts) cache log + + libE <- newEmptyMVar + + let handle = DiscordHandle { discordHandleRestChan = rest + , discordHandleGateway = gate + , discordHandleCache = cache + , discordHandleLog = log + , discordHandleLibraryError = libE + , discordHandleThreads = + [ HandleThreadIdLogger logId + , HandleThreadIdRest restId + , HandleThreadIdCache cacheId + , HandleThreadIdGateway gateId + ] + } + + finally (runDiscordLoop handle opts) + (discordOnEnd opts >> runReaderT stopDiscord handle) + +-- | Runs the main loop +runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text +runDiscordLoop handle opts = do + resp <- liftIO $ writeRestCall (discordHandleRestChan handle) GetCurrentUser + case resp of + Left (RestCallInternalErrorCode c e1 e2) -> libError $ + "HTTP Error Code " <> T.pack (show c) <> " " <> TE.decodeUtf8 e1 + <> " " <> TE.decodeUtf8 e2 + Left (RestCallInternalHttpException e) -> libError ("HTTP Exception - " <> T.pack (show e)) + Left (RestCallInternalNoParse _ _) -> libError "Couldn't parse GetCurrentUser" + _ -> do me <- liftIO . runReaderT (try $ discordOnStart opts) $ handle + case me of + Left (e :: SomeException) -> libError ("discordOnStart handler stopped on an exception:\n\n" <> T.pack (show e)) + Right _ -> loop + where + libError :: T.Text -> IO T.Text + libError msg = tryPutMVar (discordHandleLibraryError handle) msg >> pure msg + + loop :: IO T.Text + loop = do next <- race (readMVar (discordHandleLibraryError handle)) + (readChan (gatewayHandleEvents (discordHandleGateway handle))) + case next of + Left err -> libError err + Right (Left err) -> libError (T.pack (show err)) + Right (Right event) -> do + let userEvent = userFacingEvent event + let action = if discordForkThreadForEvents opts then void . forkIO + else id + action $ do me <- liftIO . runReaderT (try $ discordOnEvent opts userEvent) $ handle + case me of + Left (e :: SomeException) -> writeChan (discordHandleLog handle) + ("eventhandler - crashed on [" <> T.pack (show userEvent) <> "] " + <> " with error: " <> T.pack (show e)) + Right _ -> pure () + loop + +-- | A Error code following a rest call +data RestCallErrorCode = RestCallErrorCode Int T.Text T.Text + deriving (Show, Read, Eq, Ord) + +instance Exception RestCallErrorCode + +-- | Execute one http request and get a response +restCall :: (Request (r a), FromJSON a) => r a -> DiscordHandler (Either RestCallErrorCode a) +restCall r = do h <- ask + empty <- isEmptyMVar (discordHandleLibraryError h) + if not empty + then pure (Left (RestCallErrorCode 400 "Library Stopped Working" "")) + else do + resp <- liftIO $ writeRestCall (discordHandleRestChan h) r + case resp of + Right x -> pure (Right x) + Left (RestCallInternalErrorCode c e1 e2) -> do + pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2))) + Left (RestCallInternalHttpException _) -> + threadDelay (10 * 10^(6 :: Int)) >> restCall r + Left (RestCallInternalNoParse err dat) -> do + let formaterr = T.pack ("restcall - parse exception [" <> err <> "]" + <> " while handling" <> show dat) + writeChan (discordHandleLog h) formaterr + pure (Left (RestCallErrorCode 400 "Library Parse Exception" formaterr)) + +-- | Send a user GatewaySendable +sendCommand :: GatewaySendable -> DiscordHandler () +sendCommand e = do + h <- ask + writeChan (gatewayHandleUserSendables (discordHandleGateway h)) e + case e of + UpdateStatus opts -> liftIO $ writeIORef (gatewayHandleLastStatus (discordHandleGateway h)) (Just opts) + _ -> pure () + +-- | Access the current state of the gateway cache +readCache :: DiscordHandler Cache +readCache = do + h <- ask + merr <- readMVar (cacheHandleCache (discordHandleCache h)) + case merr of + Left (c, _) -> pure c + Right c -> pure c + + +-- | Stop all the background threads +stopDiscord :: DiscordHandler () +stopDiscord = do h <- ask + _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed" + threadDelay (10^(6 :: Int) `div` 10) + mapM_ (killThread . toId) (discordHandleThreads h) + where toId t = case t of + HandleThreadIdRest a -> a + HandleThreadIdGateway a -> a + HandleThreadIdCache a -> a + HandleThreadIdLogger a -> a + +-- | Starts the internal logger +startLogger :: (T.Text -> IO ()) -> Chan T.Text -> IO ThreadId +startLogger handle logC = forkIO $ forever $ + do me <- try $ readChan logC >>= handle + case me of + Right _ -> pure () + Left (_ :: IOException) -> + -- writeChan logC "Log handler failed" + pure () + +-- | Read the gateway latency from the last time we sent and received a +-- Heartbeat. From Europe tends to give ~110ms +getGatewayLatency :: DiscordHandler NominalDiffTime +getGatewayLatency = do + gw <- asks discordHandleGateway + (send1, send2) <- readIORef (gatewayHandleHeartbeatTimes gw) + + ack <- readIORef (gatewayHandleHeartbeatAckTimes gw) + + pure . diffUTCTime ack $ + if ack > send1 -- if the ack is before the send just gone, use the previous send + then send1 + else send2 + +-- | Measure the current latency by making a request and measuring the time +-- taken. From Europe tends to give 200ms-800ms. +-- +-- The request is getting the bot's user, which requires the `identify` scope. +measureLatency :: DiscordHandler NominalDiffTime +measureLatency = do + startTime <- liftIO getCurrentTime + _ <- restCall GetCurrentUser + endTime <- liftIO getCurrentTime + pure $ diffUTCTime endTime startTime + +-- internal note: it seems bad that it's taking 2x-8x as much time to perform +-- this specific request, considering that the latency we expect is much less. +-- might be worth looking into efficiencies or a better event to use. diff --git a/deps/discord-haskell/src/Discord/Handle.hs b/deps/discord-haskell/src/Discord/Handle.hs new file mode 100644 index 0000000..48d6641 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Handle.hs @@ -0,0 +1,38 @@ +-- | The Discord Handle. Holds all the information related to the connection. +module Discord.Handle + ( DiscordHandle(..) + , HandleThreadId(..) + ) where + +import Control.Concurrent (ThreadId, Chan, MVar) +import qualified Data.Text as T + +import Discord.Internal.Rest (RestChanHandle(..)) +import Discord.Internal.Gateway (GatewayHandle(..), CacheHandle(..)) + +-- | Thread Ids marked by what type they are +data HandleThreadId + = -- | A Rest API thread + HandleThreadIdRest ThreadId + | -- | A cache thread + HandleThreadIdCache ThreadId + | -- | A logger thread + HandleThreadIdLogger ThreadId + | -- | A gateway thread + HandleThreadIdGateway ThreadId + +-- | The main Handle structure +data DiscordHandle = DiscordHandle + { -- | Handle to the Rest loop + discordHandleRestChan :: RestChanHandle + , -- | Handle to the Websocket gateway event loop + discordHandleGateway :: GatewayHandle + , -- | Handle to the cache + discordHandleCache :: CacheHandle + , -- | List of the threads currently in use by the library + discordHandleThreads :: [HandleThreadId] + , -- | `Chan` used to send messages to the internal logger + discordHandleLog :: Chan T.Text + , -- | `MVar` containing a description of the latest library error + discordHandleLibraryError :: MVar T.Text + } diff --git a/deps/discord-haskell/src/Discord/Interactions.hs b/deps/discord-haskell/src/Discord/Interactions.hs new file mode 100644 index 0000000..45be2da --- /dev/null +++ b/deps/discord-haskell/src/Discord/Interactions.hs @@ -0,0 +1,8 @@ +module Discord.Interactions + ( module Discord.Internal.Types.ApplicationCommands, + module Discord.Internal.Types.Interactions, + ) +where + +import Discord.Internal.Types.ApplicationCommands +import Discord.Internal.Types.Interactions diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Gateway.hs new file mode 100644 index 0000000..f07be39 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Gateway.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides a rather raw interface to the websocket events +-- through a real-time Chan +module Discord.Internal.Gateway + ( GatewayHandle(..) + , CacheHandle(..) + , GatewayException(..) + , Cache(..) + , startCacheThread + , startGatewayThread + , module Discord.Internal.Types + ) where + +import Prelude hiding (log) +import Control.Concurrent.Chan (newChan, dupChan, Chan) +import Control.Concurrent (forkIO, ThreadId, newEmptyMVar, MVar) +import Data.IORef (newIORef) +import qualified Data.Text as T +import Data.Time (getCurrentTime) + +import Discord.Internal.Types (Auth, EventInternalParse, GatewayIntent) +import Discord.Internal.Gateway.EventLoop (connectionLoop, GatewayHandle(..), GatewayException(..)) +import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), CacheHandle(..)) + +-- | Starts a thread for the cache +startCacheThread :: Bool -> Chan T.Text -> IO (CacheHandle, ThreadId) +startCacheThread isEnabled log = do + events <- newChan :: IO (Chan (Either GatewayException EventInternalParse)) + cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache)) + let cacheHandle = CacheHandle events cache + tid <- forkIO $ cacheLoop isEnabled cacheHandle log + pure (cacheHandle, tid) + +-- | Create a Chan for websockets. This creates a thread that +-- writes all the received EventsInternalParse to the Chan +startGatewayThread :: Auth -> GatewayIntent -> CacheHandle -> Chan T.Text -> IO (GatewayHandle, ThreadId) +startGatewayThread auth intent cacheHandle log = do + events <- dupChan (cacheHandleEvents cacheHandle) + sends <- newChan + status <- newIORef Nothing + seqid <- newIORef 0 + seshid <- newIORef "" + host <- newIORef "gateway.discord.gg" + currTime <- getCurrentTime + hbAcks <- newIORef currTime + hbSends <- newIORef (currTime, currTime) + let gatewayHandle = GatewayHandle events sends status seqid seshid host hbAcks hbSends + tid <- forkIO $ connectionLoop auth intent gatewayHandle log + pure (gatewayHandle, tid) diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs new file mode 100644 index 0000000..a4f228a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Gateway/Cache.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | Query info about connected Guilds and Channels +module Discord.Internal.Gateway.Cache where + +import Prelude hiding (log) +import Control.Monad (forever, join) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.Foldable (foldl') +import qualified Data.Map.Strict as M +import qualified Data.Text as T + +import Discord.Internal.Types +import Discord.Internal.Gateway.EventLoop + +data Cache = Cache + { cacheCurrentUser :: !User + , cacheDMChannels :: !(M.Map ChannelId Channel) + , cacheGuilds :: !(M.Map GuildId (Maybe (Guild, Maybe GuildCreateData))) + , cacheChannels :: !(M.Map ChannelId Channel) + , cacheApplication :: !PartialApplication + } deriving (Show) + +data CacheHandle = CacheHandle + { cacheHandleEvents :: Chan (Either GatewayException EventInternalParse) + , cacheHandleCache :: MVar (Either (Cache, GatewayException) Cache) + } + +cacheLoop :: Bool -> CacheHandle -> Chan T.Text -> IO () +cacheLoop isEnabled cacheHandle log = do + ready <- readChan eventChan + case ready of + Right (InternalReady _ user _ _ _ _ pApp) -> do + putMVar cache (Right (Cache user M.empty M.empty M.empty pApp)) + loop + Right r -> + writeChan log ("cache - stopping cache - expected Ready event, but got " <> T.pack (show r)) + Left e -> + writeChan log ("cache - stopping cache - gateway exception " <> T.pack (show e)) + where + cache = cacheHandleCache cacheHandle + eventChan = cacheHandleEvents cacheHandle + + loop :: IO () + loop = forever $ do + eventOrExcept <- readChan eventChan + if not isEnabled + then return () + else do + minfo <- takeMVar cache + case minfo of + Left nope -> putMVar cache (Left nope) + Right info -> case eventOrExcept of + Left e -> putMVar cache (Left (info, e)) + Right event -> putMVar cache $! Right $! adjustCache info event + +adjustCache :: Cache -> EventInternalParse -> Cache +adjustCache minfo event = case event of + InternalReady _ _ gus _ _ _ pa -> minfo { cacheApplication = pa, cacheGuilds = M.union (cacheGuilds minfo) (M.fromList $ (\gu -> (idOnceAvailable gu, Nothing)) <$> gus) } + + InternalGuildCreate guild guildData -> + let newChans = guildCreateChannels guildData + g = M.insert (guildId guild) (Just (guild, Just guildData)) (cacheGuilds minfo) + c = M.union + (M.fromList [ (channelId ch, ch) | ch <- newChans ]) + (cacheChannels minfo) + in minfo { cacheGuilds = g, cacheChannels = c } + InternalGuildUpdate guild -> + let gs = M.alter (\case Just (Just (_, mCD)) -> Just (Just (guild, mCD)) ; _ -> Just (Just (guild, Nothing)); ) (guildId guild) $ cacheGuilds minfo + in minfo { cacheGuilds = gs } + InternalGuildDelete guild -> + let + toDelete = join $ cacheGuilds minfo M.!? idOnceAvailable guild + extraData = snd =<< toDelete + channels = maybe [] (fmap channelId . guildCreateChannels) extraData + g = M.delete (idOnceAvailable guild) (cacheGuilds minfo) + c = foldl' (flip M.delete) (cacheChannels minfo) channels + in minfo { cacheGuilds = g, cacheChannels = c } + InternalChannelCreate c -> + let cm = M.insert (channelId c) c (cacheChannels minfo) + in minfo { cacheChannels = cm } + InternalChannelUpdate c -> + let cm = M.insert (channelId c) c (cacheChannels minfo) + in minfo { cacheChannels = cm } + InternalChannelDelete c -> + let cm = M.delete (channelId c) (cacheChannels minfo) + in minfo { cacheChannels = cm } + _ -> minfo diff --git a/deps/discord-haskell/src/Discord/Internal/Gateway/EventLoop.hs b/deps/discord-haskell/src/Discord/Internal/Gateway/EventLoop.hs new file mode 100644 index 0000000..dfcd00f --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Gateway/EventLoop.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Provides logic code for interacting with the Discord websocket +-- gateway. Realistically, this is probably lower level than most +-- people will need +module Discord.Internal.Gateway.EventLoop where + +import Prelude hiding (log) + +import Control.Monad (forever, void) +import Control.Monad.Random (getRandomR) +import Control.Concurrent.Async (race) +import Control.Concurrent.Chan +import Control.Concurrent (threadDelay, killThread, forkIO) +import Control.Exception.Safe (try, finally, SomeException) +import Data.IORef +import Data.Aeson (eitherDecode, encode) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as BL +import Data.Time (getCurrentTime) + +import Wuss (runSecureClient) +import Network.Socket (HostName) +import Network.WebSockets (ConnectionException(..), Connection, + receiveData, sendTextData, sendClose) + +import Discord.Internal.Types +import Discord.Internal.Rest.Prelude (apiVersion) + + +-- | Info the event processing loop needs to +data GatewayHandle = GatewayHandle + { -- | Realtime events from discord + gatewayHandleEvents :: Chan (Either GatewayException EventInternalParse), + -- | Events the user sends to discord + gatewayHandleUserSendables :: Chan GatewaySendable, + -- | Recent set status (resent to discord on reconnect) + gatewayHandleLastStatus :: IORef (Maybe UpdateStatusOpts), + -- | Recent sent event sequence (used to reconnect) + gatewayHandleLastSequenceId :: IORef Integer, + -- | Which discord server session (used to reconnect) + gatewayHandleSessionId :: IORef T.Text, + -- | Which discord gateway to connect to. This should contain a default value + -- ("gateway.discord.gg") on first connect, but on subsequent Resumes this + -- may contain a different value. This should never contain trailing slashes, + -- or any "wss://" prefixes, since HostNames of this kind are not supported + -- by the websockets library. + gatewayHandleHostname :: IORef HostName, + -- | The last time a heartbeatack was received + gatewayHandleHeartbeatAckTimes :: IORef UTCTime, + -- | The last two times a heartbeat was sent + gatewayHandleHeartbeatTimes :: IORef (UTCTime, UTCTime) + } + +-- | Ways the gateway connection can fail with no possibility of recovery. +newtype GatewayException = GatewayExceptionIntent T.Text + deriving (Show) + + +-- | State of the eventloop +data LoopState = LoopStart + | LoopClosed + | LoopReconnect + deriving Show + +-- | Info the sendableLoop reads when it writes to the websocket +data SendablesData = SendablesData + { sendableConnection :: Connection + , librarySendables :: Chan GatewaySendableInternal + , startsendingUsers :: IORef Bool + , heartbeatInterval :: Integer + } + + +-- | Gateway connection infinite loop. Get events from websocket and send them to the library user +-- +-- @ +-- Auth needed to connect +-- GatewayIntent needed to connect +-- GatewayHandle (eventsGives,status,usersends,seq,sesh) needed all over +-- log :: Chan (T.Text) needed all over +-- +-- sendableConnection set by setup, need sendableLoop +-- librarySendables :: Chan (GatewaySendableInternal) set by setup, need heartbeat +-- heartbeatInterval :: Int set by Hello, need heartbeat +-- +-- sequenceId :: Int id of last event received set by Resume, need heartbeat and reconnect +-- sessionId :: Text set by Ready, need reconnect +-- @ +connectionLoop :: Auth -> GatewayIntent -> GatewayHandle -> Chan T.Text -> IO () +connectionLoop auth intent gatewayHandle log = outerloop LoopStart + where + + -- | Main connection loop. Catch exceptions and reconnect. + outerloop :: LoopState -> IO () + outerloop state = do + gatewayHost <- readIORef (gatewayHandleHostname gatewayHandle) + mfirst <- firstmessage state -- construct first message + case mfirst of + Nothing -> pure () -- close + + Just message -> do + nextstate <- try (startOneConnection gatewayHost message) -- connection + case nextstate :: Either SomeException LoopState of + Left _ -> do t <- getRandomR (3,20) + threadDelay (t * (10^(6 :: Int))) + writeChan log "gateway - trying to reconnect after failure(s)" + outerloop LoopReconnect + Right n -> outerloop n + + -- | Construct the initial websocket message to send based on which state of the loop. + -- Fresh start is Identify and a reconnect is Resume + firstmessage :: LoopState -> IO (Maybe GatewaySendableInternal) + firstmessage state = + case state of + LoopStart -> pure $ Just $ Identify auth intent (0, 1) + LoopReconnect -> do seqId <- readIORef (gatewayHandleLastSequenceId gatewayHandle) + seshId <- readIORef (gatewayHandleSessionId gatewayHandle) + if seshId == "" + then do writeChan log "gateway - WARNING seshID was not set by READY?" + pure $ Just $ Identify auth intent (0, 1) + else pure $ Just $ Resume auth seshId seqId + LoopClosed -> pure Nothing + + startOneConnection + :: HostName + -- ^ The gateway address to connect to. Should be "gateway.discord.gg" on first try, but + -- all Resumes should go to the resume_gateway_url specified in the Ready event + -- https://discord.com/developers/docs/change-log#sessionspecific-gateway-resume-urls + -> GatewaySendableInternal + -- ^ The first message to send. Either an Identify or Resume. + -> IO LoopState + startOneConnection gatewayAddr message = runSecureClient gatewayAddr 443 ("/?v=" <> T.unpack apiVersion <>"&encoding=json") $ \conn -> do + msg <- getPayload conn log + case msg of + Right (Hello interval) -> do + -- setup sendables data + internal <- newChan :: IO (Chan GatewaySendableInternal) + sendingUser <- newIORef False + let sending = SendablesData { sendableConnection = conn + , librarySendables = internal + , startsendingUsers = sendingUser + , heartbeatInterval = interval + } + -- start websocket sending loop + sendsId <- forkIO $ sendableLoop conn gatewayHandle sending log + heart <- forkIO $ heartbeat sending (gatewayHandleHeartbeatTimes gatewayHandle) (gatewayHandleLastSequenceId gatewayHandle) + writeChan internal message + + -- run connection eventloop + finally (runEventLoop gatewayHandle sending log) + (killThread heart >> killThread sendsId) + + _ -> do + writeChan log "gateway - WARNING could not connect. Expected hello" + sendClose conn ("expected hello" :: BL.ByteString) + void $ forever $ void (receiveData conn :: IO BL.ByteString) + -- > after sendClose you should call receiveDataMessage until + -- > it throws an exception + -- haskell websockets documentation + threadDelay (3 * (10^(6 :: Int))) + pure LoopStart + + +-- | Process events from discord and write them to the onDiscordEvent Channel +runEventLoop :: GatewayHandle -> SendablesData -> Chan T.Text -> IO LoopState +runEventLoop thehandle sendablesData log = do loop + where + eventChan :: Chan (Either GatewayException EventInternalParse) + eventChan = gatewayHandleEvents thehandle + + -- | Keep receiving Dispatch events until a reconnect or a restart + loop = do + eitherPayload <- getPayloadTimeout sendablesData log + case eitherPayload :: Either ConnectionException GatewayReceivable of + + Right (Dispatch event sq) -> do -- GOT AN EVENT: + writeIORef (gatewayHandleLastSequenceId thehandle) sq + writeChan eventChan (Right event) -- send the event to user + case event of + (InternalReady _ _ _ seshID resumeHost _ _) -> do + writeIORef (gatewayHandleSessionId thehandle) seshID + writeIORef (gatewayHandleHostname thehandle) resumeHost + _ -> writeIORef (startsendingUsers sendablesData) True + loop + Right (Hello _interval) -> do writeChan log "eventloop - unexpected hello" + loop + Right (HeartbeatRequest sq) -> do writeIORef (gatewayHandleLastSequenceId thehandle) sq + sendHeartbeat sendablesData (gatewayHandleHeartbeatTimes thehandle) sq + loop + Right (InvalidSession retry) -> pure $ if retry then LoopReconnect else LoopStart + Right Reconnect -> pure LoopReconnect + Right HeartbeatAck -> do + currTime <- getCurrentTime + _ <- atomicModifyIORef' (gatewayHandleHeartbeatAckTimes thehandle) (dupe . const currTime) + loop + Right (ParseError _) -> loop -- getPayload logs the parse error. nothing to do here + + Left (CloseRequest code str) -> case code of + -- see Discord and MDN documentation on gateway close event codes + -- https://discord.com/developers/docs/topics/opcodes-and-status-codes#gateway-gateway-close-event-codes + -- https://developer.mozilla.org/en-US/docs/Web/API/CloseEvent#properties + 1000 -> pure LoopReconnect + 1001 -> pure LoopReconnect + 4000 -> pure LoopReconnect + 4006 -> pure LoopStart + 4007 -> pure LoopStart + 4014 -> do writeChan eventChan (Left (GatewayExceptionIntent $ + "Tried to declare an unauthorized GatewayIntent. " <> + "Use the discord app manager to authorize by following: " <> + "https://github.com/discord-haskell/discord-haskell/blob/master/docs/intents.md")) + pure LoopClosed + _ -> do writeChan log ("gateway - unknown websocket close code " <> T.pack (show code) + <> " [" <> TE.decodeUtf8 (BL.toStrict str) <> "]. Consider opening an issue " + <> "https://github.com/discord-haskell/discord-haskell/issues") + pure LoopStart + Left _ -> pure LoopReconnect + + +-- | Blocking wait for next payload from the websocket (returns "Reconnect" after 1.5*heartbeatInterval seconds) +getPayloadTimeout :: SendablesData -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) +getPayloadTimeout sendablesData log = do + let interval = heartbeatInterval sendablesData + res <- race (threadDelay (fromInteger ((interval * 1000 * 3) `div` 2))) + (getPayload (sendableConnection sendablesData) log) + case res of + Left () -> pure (Right Reconnect) + Right other -> pure other + +-- | Blocking wait for next payload from the websocket +getPayload :: Connection -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) +getPayload conn log = try $ do + msg' <- receiveData conn + case eitherDecode msg' of + Right msg -> pure msg + Left err -> do writeChan log ("gateway - received exception [" <> T.pack err <> "]" + <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg')) + pure (ParseError (T.pack err)) + +-- | Infinite loop to send heartbeats to the chan +heartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> IORef Integer -> IO () +heartbeat sendablesData sendTimes seqKey = do + threadDelay (3 * 10^(6 :: Int)) + forever $ do + num <- readIORef seqKey + sendHeartbeat sendablesData sendTimes num + threadDelay (fromInteger (heartbeatInterval sendablesData * 1000)) + +sendHeartbeat :: SendablesData -> IORef (UTCTime, UTCTime) -> Integer -> IO () +sendHeartbeat sendablesData sendTimes seqKey = do + currTime <- getCurrentTime + _ <- atomicModifyIORef' sendTimes (dupe . (currTime,) . fst) + writeChan (librarySendables sendablesData) (Heartbeat seqKey) + +-- | Infinite loop to send library/user events to discord with the actual websocket connection +sendableLoop :: Connection -> GatewayHandle -> SendablesData -> Chan T.Text -> IO () +sendableLoop conn ghandle sendablesData _log = sendLoop + where + sendLoop = do + -- send a ~120 events a min by delaying + threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double) + -- payload :: Either GatewaySendableInternal GatewaySendable + payload <- race nextLibrary nextUser + sendTextData conn (either encode encode payload) + sendLoop + + -- | next event sent by library + nextLibrary :: IO GatewaySendableInternal + nextLibrary = readChan (librarySendables sendablesData) + + -- | next event sent by user (once startsendingUsers is set) + nextUser :: IO GatewaySendable + nextUser = do usersending <- readIORef (startsendingUsers sendablesData) + if usersending + then readChan (gatewayHandleUserSendables ghandle) + else threadDelay (4 * (10^(6::Int))) >> nextUser + +dupe :: a -> (a, a) +dupe a = (a, a) diff --git a/deps/discord-haskell/src/Discord/Internal/Rest.hs b/deps/discord-haskell/src/Discord/Internal/Rest.hs new file mode 100644 index 0000000..0ddaff0 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides a higher level interface to the rest functions. +-- Preperly writes to the rate-limit loop. Creates separate +-- MVars for each call +module Discord.Internal.Rest + ( module Discord.Internal.Types + , RestChanHandle(..) + , Request(..) + , writeRestCall + , startRestThread + , RestCallInternalException(..) + ) where + +import Prelude hiding (log) +import Data.Aeson (FromJSON, eitherDecode) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent (forkIO, ThreadId) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + + +import Discord.Internal.Types +import Discord.Internal.Rest.HTTP + +-- | Handle to the Rest 'Chan' +data RestChanHandle = RestChanHandle + { restHandleChan :: Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) + } + +-- | Starts the http request thread. Please only call this once +startRestThread :: Auth -> Chan T.Text -> IO (RestChanHandle, ThreadId) +startRestThread auth log = do + c <- newChan + tid <- forkIO $ restLoop auth c log + pure (RestChanHandle c, tid) + +-- | Execute a request blocking until a response is received +writeRestCall :: (Request (r a), FromJSON a) => RestChanHandle -> r a -> IO (Either RestCallInternalException a) +writeRestCall c req = do + m <- newEmptyMVar + writeChan (restHandleChan c) (majorRoute req, jsonRequest req, m) + r <- readMVar m + pure $ case eitherDecode <$> r of + Right (Right o) -> Right o + (Right (Left er)) -> Left (RestCallInternalNoParse er (case r of + Right x -> x + Left _ -> "")) + Left e -> Left e + + diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationCommands.hs b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationCommands.hs new file mode 100644 index 0000000..9ed33b3 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/ApplicationCommands.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Discord.Internal.Rest.ApplicationCommands where + +import Data.Aeson (Value) +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Discord.Internal.Types.ApplicationCommands + ( ApplicationCommandPermissions, + GuildApplicationCommandPermissions(GuildApplicationCommandPermissions), + EditApplicationCommand, + CreateApplicationCommand, + ApplicationCommand ) +import Network.HTTP.Req as R + +instance Request (ApplicationCommandRequest a) where + jsonRequest = applicationCommandJsonRequest + majorRoute = applicationCommandMajorRoute + +-- | Requests related to application commands +data ApplicationCommandRequest a where + -- | Fetch all of the global commands for your application. Returns an list of 'ApplicationCommand's. + GetGlobalApplicationCommands :: ApplicationId + -> ApplicationCommandRequest [ApplicationCommand] + -- | Create a new global command. Returns an 'ApplicationCommand'. + -- + -- __Note__: Creating a command with the same name as an existing command for your application will overwrite the old command. + CreateGlobalApplicationCommand :: ApplicationId + -> CreateApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Fetch a global command for your application. Returns an 'ApplicationCommand'. + GetGlobalApplicationCommand :: ApplicationId + -> ApplicationCommandId + -> ApplicationCommandRequest ApplicationCommand + -- | Edit a global command. Returns an 'ApplicationCommand'. + -- + -- All fields are optional, but any fields provided will entirely overwrite the existing values of those fields. + EditGlobalApplicationCommand :: ApplicationId + -> ApplicationCommandId + -> EditApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Delete a global command. + DeleteGlobalApplicationCommand :: ApplicationId + -> ApplicationCommandId + -> ApplicationCommandRequest () + -- | Takes a list of 'CreateApplicationCommand', overwriting the existing global command list for this application. + -- + -- __Note__: This will overwrite __all__ types of application commands: slash commands, user commands, and message commands. + BulkOverWriteGlobalApplicationCommand :: ApplicationId + -> [CreateApplicationCommand] + -> ApplicationCommandRequest () + -- | Fetch all of the guild commands for your application for a specific guild. Returns an list of 'ApplicationCommands'. + GetGuildApplicationCommands :: ApplicationId + -> GuildId + -> ApplicationCommandRequest [ApplicationCommand] + -- | Create a new guild command. New guild commands will be available in the guild immediately. + -- Returns an 'ApplicationCommand'. + -- If the command did not already exist, it will count toward daily application command create limits. + -- + -- __Note__: Creating a command with the same name as an existing command for your application will overwrite the old command. + CreateGuildApplicationCommand :: ApplicationId + -> GuildId + -> CreateApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Fetch a guild command for your application. Returns an 'ApplicationCommand' + GetGuildApplicationCommand :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> ApplicationCommandRequest ApplicationCommand + -- | Edit a guild command. Updates for guild commands will be available immediately. Returns an 'ApplicationCommand'. + -- All fields are optional, but any fields provided will entirely overwrite the existing values of those fields. + EditGuildApplicationCommand :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> CreateApplicationCommand + -> ApplicationCommandRequest ApplicationCommand + -- | Delete a guild command. + DeleteGuildApplicationCommand :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> ApplicationCommandRequest () + -- | Takes a list of `CreateApplicationCommand`, overwriting the existing command list for this application for the targeted guild. + -- + -- __Note__: This will overwrite __all__ types of application commands: slash commands, user commands, and message commands. + BulkOverWriteGuildApplicationCommand :: ApplicationId + -> GuildId + -> [CreateApplicationCommand] + -> ApplicationCommandRequest () + -- | Fetches permissions for all commands for your application in a guild. + GetGuildApplicationCommandPermissions :: ApplicationId + -> GuildId + -> ApplicationCommandRequest GuildApplicationCommandPermissions + -- | Fetches permissions for a specific command for your application in a guild. + GetApplicationCommandPermissions :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> ApplicationCommandRequest GuildApplicationCommandPermissions + -- | Edits command permissions for a specific command for your application. + -- You can add up to 100 permission overwrites for a command. + -- __Notes__: + -- + -- * This endpoint will overwrite existing permissions for the command in that guild + -- * This endpoint requires authentication with a Bearer token that has permission to manage the guild and its roles. + -- * Deleting or renaming a command will permanently delete all permissions for the command + EditApplicationCommandPermissions :: ApplicationId + -> GuildId + -> ApplicationCommandId + -> [ApplicationCommandPermissions] + -> ApplicationCommandRequest GuildApplicationCommandPermissions + +-- | The base url for application commands +applications :: ApplicationId -> R.Url 'R.Https +applications s = baseUrl /: "applications" /~ s + +-- | The major routes identifiers for `ApplicationCommandRequest`s +applicationCommandMajorRoute :: ApplicationCommandRequest a -> String +applicationCommandMajorRoute a = case a of + (GetGlobalApplicationCommands aid) -> "get_glob_appcomm" <> show aid + (CreateGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (GetGlobalApplicationCommand aid _) -> "get_glob_appcomm" <> show aid + (EditGlobalApplicationCommand aid _ _) -> "write_glob_appcomm" <> show aid + (DeleteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (BulkOverWriteGlobalApplicationCommand aid _) -> "write_glob_appcomm" <> show aid + (GetGuildApplicationCommands aid _) -> "get_appcomm" <> show aid + (CreateGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (GetGuildApplicationCommand aid _ _) -> "get_appcomm" <> show aid + (EditGuildApplicationCommand aid _ _ _) -> "write_appcomm" <> show aid + (DeleteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (BulkOverWriteGuildApplicationCommand aid _ _) -> "write_appcomm" <> show aid + (GetGuildApplicationCommandPermissions aid _) -> "appcom_perm " <> show aid + (GetApplicationCommandPermissions aid _ _) -> "appcom_perm " <> show aid + (EditApplicationCommandPermissions aid _ _ _) -> "appcom_perm " <> show aid + +-- | The `JsonRequest`s for `ApplicationCommandRequest`s +applicationCommandJsonRequest :: ApplicationCommandRequest a -> JsonRequest +applicationCommandJsonRequest a = case a of + (GetGlobalApplicationCommands aid) -> + Get (applications aid /: "commands") mempty + (CreateGlobalApplicationCommand aid cac) -> + Post (applications aid /: "commands") (convert cac) mempty + (GetGlobalApplicationCommand aid aci) -> + Get (applications aid /: "commands" /~ aci) mempty + (EditGlobalApplicationCommand aid aci eac) -> + Patch (applications aid /: "commands" /~ aci) (convert eac) mempty + (DeleteGlobalApplicationCommand aid aci) -> + Delete (applications aid /: "commands" /~ aci) mempty + (BulkOverWriteGlobalApplicationCommand aid cacs) -> + Put (applications aid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty + (GetGuildApplicationCommands aid gid) -> + Get (applications aid /: "guilds" /~ gid /: "commands") mempty + (CreateGuildApplicationCommand aid gid cac) -> + Post (applications aid /: "guilds" /~ gid /: "commands") (convert cac) mempty + (GetGuildApplicationCommand aid gid aci) -> + Get (applications aid /: "guilds" /~ gid /: "commands" /~ aci) mempty + (EditGuildApplicationCommand aid gid aci eac) -> + Patch (applications aid /: "guilds" /~ gid /: "commands" /~ aci) (convert eac) mempty + (DeleteGuildApplicationCommand aid gid aci) -> + Delete (applications aid /: "guilds" /~ gid /: "commands" /~ aci) mempty + (BulkOverWriteGuildApplicationCommand aid gid cacs) -> + Put (applications aid /: "guilds" /~ gid /: "commands") (R.ReqBodyJson $ toJSON cacs) mempty + (GetGuildApplicationCommandPermissions aid gid) -> + Get (applications aid /: "guilds" /~ gid /: "commands" /: "permissions") mempty + (GetApplicationCommandPermissions aid gid cid) -> + Get (applications aid /: "guilds" /~ gid /: "commands" /~ cid /: "permissions") mempty + (EditApplicationCommandPermissions aid gid cid ps) -> + Put (applications aid /: "guilds" /~ gid /: "commands" /~ cid /: "permissions") (R.ReqBodyJson $ toJSON (GuildApplicationCommandPermissions cid aid gid ps)) mempty + where + convert :: (ToJSON a) => a -> RestIO (ReqBodyJson Value) + convert = (pure @RestIO) . R.ReqBodyJson . toJSON diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs new file mode 100644 index 0000000..1024d9d --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Channel.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Channel + ( ChannelRequest(..) + , MessageDetailedOpts(..) + , AllowedMentions(..) + , ReactionTiming(..) + , MessageTiming(..) + , ChannelInviteOpts(..) + , ModifyChannelOpts(..) + , ChannelPermissionsOpts(..) + , GroupDMAddRecipientOpts(..) + , StartThreadOpts(..) + , StartThreadNoMessageOpts(..) + , ListThreads(..) + ) where + + +import Data.Aeson +import Data.Default (Default, def) +import Data.Emoji (unicodeByName) +import qualified Data.Text as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody, partBS) +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Control.Monad (join) + +instance Request (ChannelRequest a) where + majorRoute = channelMajorRoute + jsonRequest = channelJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data ChannelRequest a where + -- | Gets a channel by its id. + GetChannel :: ChannelId -> ChannelRequest Channel + -- | Edits channels options. + ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel + -- | Deletes a channel if its id doesn't equal to the id of guild. + DeleteChannel :: ChannelId -> ChannelRequest Channel + -- | Gets a messages from a channel with limit of 100 per request. + GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message] + -- | Gets a message in a channel by its id. + GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message + -- | Sends a message to a channel. + CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message + -- | Sends a message with granular controls. + CreateMessageDetailed :: ChannelId -> MessageDetailedOpts -> ChannelRequest Message + -- | Add an emoji reaction to a message. ID must be present for custom emoji + CreateReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + -- | Remove a Reaction this bot added + DeleteOwnReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + -- | Remove a Reaction someone else added + DeleteUserReaction :: (ChannelId, MessageId) -> UserId -> T.Text -> ChannelRequest () + -- | Deletes all reactions of a single emoji on a message + DeleteSingleReaction :: (ChannelId, MessageId) -> T.Text -> ChannelRequest () + -- | List of users that reacted with this emoji + GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest [User] + -- | Delete all reactions on a message + DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () + -- | Edits a message content. + EditMessage :: (ChannelId, MessageId) -> MessageDetailedOpts + -> ChannelRequest Message + -- | Deletes a message. + DeleteMessage :: (ChannelId, MessageId) -> ChannelRequest () + -- | Deletes a group of messages. + BulkDeleteMessage :: (ChannelId, [MessageId]) -> ChannelRequest () + -- | Edits a permission overrides for a channel. + EditChannelPermissions :: ChannelId -> Either RoleId UserId -> ChannelPermissionsOpts -> ChannelRequest () + -- | Gets all instant invites to a channel. + GetChannelInvites :: ChannelId -> ChannelRequest Object + -- | Creates an instant invite to a channel. + CreateChannelInvite :: ChannelId -> ChannelInviteOpts -> ChannelRequest Invite + -- | Deletes a permission override from a channel. + DeleteChannelPermission :: ChannelId -> Either RoleId UserId -> ChannelRequest () + -- | Sends a typing indicator a channel which lasts 10 seconds. + TriggerTypingIndicator :: ChannelId -> ChannelRequest () + -- | Gets all pinned messages of a channel. + GetPinnedMessages :: ChannelId -> ChannelRequest [Message] + -- | Pins a message. + AddPinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + -- | Unpins a message. + DeletePinnedMessage :: (ChannelId, MessageId) -> ChannelRequest () + -- | Adds a recipient to a Group DM using their access token + GroupDMAddRecipient :: ChannelId -> GroupDMAddRecipientOpts -> ChannelRequest () + -- | Removes a recipient from a Group DM + GroupDMRemoveRecipient :: ChannelId -> UserId -> ChannelRequest () + -- | Start a thread from a message + StartThreadFromMessage :: ChannelId -> MessageId -> StartThreadOpts -> ChannelRequest Channel + -- | Start a thread without a message + StartThreadNoMessage :: ChannelId -> StartThreadNoMessageOpts -> ChannelRequest Channel + -- | Join a thread + JoinThread :: ChannelId -> ChannelRequest () + -- | Add a thread member + AddThreadMember :: ChannelId -> UserId -> ChannelRequest () + -- | Leave a thread + LeaveThread :: ChannelId -> ChannelRequest () + -- | Remove a thread member + RemoveThreadMember :: ChannelId -> UserId -> ChannelRequest () + -- | Get a thread member + GetThreadMember :: ChannelId -> UserId -> ChannelRequest ThreadMember + -- | List the thread members + ListThreadMembers :: ChannelId -> ChannelRequest [ThreadMember] + -- | List public archived threads in the given channel. Optionally before a + -- given time, and optional maximum number of threads. Returns the threads, + -- thread members, and whether there are more to collect. + -- Requires the READ_MESSAGE_HISTORY permission. + ListPublicArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + -- | List private archived threads in the given channel. Optionally before a + -- given time, and optional maximum number of threads. Returns the threads, + -- thread members, and whether there are more to collect. + -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. + ListPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + -- | List joined private archived threads in the given channel. Optionally + -- before a given time, and optional maximum number of threads. Returns the + -- threads, thread members, and whether there are more to collect. + -- Requires both the READ_MESSAGE_HISTORY and MANAGE_THREADS permissions. + ListJoinedPrivateArchivedThreads :: ChannelId -> (Maybe UTCTime, Maybe Integer) -> ChannelRequest ListThreads + + +-- | Options for `CreateMessageDetailed` requests. +data MessageDetailedOpts = MessageDetailedOpts + { -- | The message contents (up to 2000 characters) + messageDetailedContent :: T.Text + , -- | `True` if this is a TTS message + messageDetailedTTS :: Bool + , -- | embedded rich content (up to 6000 characters) + messageDetailedEmbeds :: Maybe [CreateEmbed] + , -- | the contents of the file being sent + messageDetailedFile :: Maybe (T.Text, B.ByteString) + , -- | allowed mentions for the message + messageDetailedAllowedMentions :: Maybe AllowedMentions + , -- | If `Just`, reply to the message referenced + messageDetailedReference :: Maybe MessageReference + , -- | Message components for the message + messageDetailedComponents :: Maybe [ActionRow] + , -- | IDs of up to 3 `Sticker` in the server to send with the message + messageDetailedStickerIds :: Maybe [StickerId] + } deriving (Show, Read, Eq, Ord) + +instance Default MessageDetailedOpts where + def = MessageDetailedOpts { messageDetailedContent = "" + , messageDetailedTTS = False + , messageDetailedEmbeds = Nothing + , messageDetailedFile = Nothing + , messageDetailedAllowedMentions = Nothing + , messageDetailedReference = Nothing + , messageDetailedComponents = Nothing + , messageDetailedStickerIds = Nothing + } + +-- | Data constructor for `GetReactions` requests +data ReactionTiming = BeforeReaction MessageId + | AfterReaction MessageId + | LatestReaction + deriving (Show, Read, Eq, Ord) + +reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https +reactionTimingToQuery t = case t of + (BeforeReaction snow) -> "before" R.=: show snow + (AfterReaction snow) -> "after" R.=: show snow + LatestReaction -> mempty + +-- | Data constructor for `GetChannelMessages` requests. +-- +-- See <https://discord.com/developers/docs/resources/channel#get-channel-messages> +data MessageTiming = AroundMessage MessageId + | BeforeMessage MessageId + | AfterMessage MessageId + | LatestMessages + deriving (Show, Read, Eq, Ord) + +messageTimingToQuery :: MessageTiming -> R.Option 'R.Https +messageTimingToQuery t = case t of + (AroundMessage snow) -> "around" R.=: show snow + (BeforeMessage snow) -> "before" R.=: show snow + (AfterMessage snow) -> "after" R.=: show snow + LatestMessages -> mempty + +-- | Options for `CreateChannelInvite` requests +data ChannelInviteOpts = ChannelInviteOpts + { -- | How long the invite is valid for (in seconds) + channelInviteOptsMaxAgeSeconds :: Maybe Integer + , -- | How many uses the invite is valid for + channelInviteOptsMaxUsages :: Maybe Integer + , -- | Whether this invite only grants temporary membership + channelInviteOptsIsTemporary :: Maybe Bool + , -- | Don't reuse a similar invite. Useful for creating many unique one time + -- use invites + channelInviteOptsDontReuseSimilarInvite :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ChannelInviteOpts where + toJSON ChannelInviteOpts{..} = objectFromMaybes + ["max_age" .=? channelInviteOptsMaxAgeSeconds, + "max_uses" .=? channelInviteOptsMaxUsages, + "temporary" .=? channelInviteOptsIsTemporary, + "unique" .=? channelInviteOptsDontReuseSimilarInvite ] + +-- | Options for `ModifyChannel` requests +data ModifyChannelOpts = ModifyChannelOpts + { -- | (All) The name of the channel (max 100 characters) + modifyChannelName :: Maybe T.Text + , -- | (All) Position of the channel in the listing + modifyChannelPosition :: Maybe Integer + , -- | (Text) The channel topic text (max 1024 characters) + modifyChannelTopic :: Maybe T.Text + , -- | (Text) Wether the channel is tagged as NSFW + modifyChannelNSFW :: Maybe Bool + , -- | (Voice) Bitrate (in bps) of a voice channel. Min 8000, max 96000 + -- (128000 for boosted servers) + modifyChannelBitrate :: Maybe Integer + , -- | (Text) The rate limit of the channel, in seconds (0-21600), does not + -- affect bots and users with @manage_channel@ or @manage_messages@ + -- permissons + modifyChannelUserRateLimit :: Maybe Integer + , -- | (Voice) the user limit of the voice channel, max 99 + modifyChannelUserLimit :: Maybe Integer + , -- | (All) The channel permissions + modifyChannelPermissionOverwrites :: Maybe [Overwrite] + , -- | (All) The parent category of the channel + modifyChannelParentId :: Maybe ChannelId + , -- | (Text) Auto-archive duration for Threads + modifyChannelDefaultAutoArchive :: Maybe Integer + , -- | (Thread) Whether the thread is archived + modifyChannelThreadArchived :: Maybe Bool + , -- | (Thread) duration in minutes to automatically archive the thread after + -- recent activity, can be set to: 60, 1440, 4320 or 10080 + modifyChannelThreadAutoArchive :: Maybe Integer + , -- | (Thread) Whether the thread is locked. When a thread is locked, only + -- users with @manage_threads@ can unarchive it + modifyChannelThreadLocked :: Maybe Bool + , -- | (Thread) Whether non-moderators can add other non-moderators to a + -- thread. Only available on private threads + modifyChannelThreadInvitable :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance Default ModifyChannelOpts where + def = ModifyChannelOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON ModifyChannelOpts where + toJSON ModifyChannelOpts{..} = objectFromMaybes + ["name" .=? modifyChannelName, + "position" .=? modifyChannelPosition, + "topic" .=? modifyChannelTopic, + "nsfw" .=? modifyChannelNSFW, + "bitrate" .=? modifyChannelBitrate, + "rate_limit_per_user" .=? modifyChannelUserRateLimit, + "user_limit" .=? modifyChannelUserLimit, + "permission_overwrites" .=? modifyChannelPermissionOverwrites, + "parent_id" .=? modifyChannelParentId, + "default_auto_archive_duration" .=? modifyChannelDefaultAutoArchive, + "archived" .=? modifyChannelThreadArchived, + "auto_archive_duration" .=? modifyChannelThreadAutoArchive, + "locked" .=? modifyChannelThreadLocked, + "invitable" .=? modifyChannelThreadInvitable ] + +-- | Options for The `EditChannelPermissions` request +-- +-- Since the JSON encoding of this datatype will require information in the +-- route (the Either decides whether the overwrite is for a user or a role), we +-- do not provide a ToJSON instance. Instead, the JSON is manually constructed +-- in the 'channelJsonRequest' function. +data ChannelPermissionsOpts = ChannelPermissionsOpts + { -- | The permission integer for the explicitly allowed permissions + channelPermissionsOptsAllow :: Integer + , -- | The permission integer for the explicitly denied permissions + channelPermissionsOptsDeny :: Integer + } deriving (Show, Read, Eq, Ord) + +-- | Options for `GroupDMAddRecipient` request +-- +-- See <https://discord.com/developers/docs/resources/channel#group-dm-add-recipient> +data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts + { -- | The id of the user to add to the Group DM + groupDMAddRecipientUserToAdd :: UserId + , -- | The nickname given to the user being added + groupDMAddRecipientUserToAddNickName :: T.Text + , -- | Access token of the user. That user must have granted your app the + -- @gdm.join@ scope. + groupDMAddRecipientGDMJoinAccessToken :: T.Text + } deriving (Show, Read, Eq, Ord) + +-- | Options for `StartThreadFromMessage` request +data StartThreadOpts = StartThreadOpts + { -- | Name of the thread + startThreadName :: T.Text + , -- | Period of innactivity after which the thread gets archived in minutes. + -- + -- Can be one of 60, 1440, 4320, 10080 + startThreadAutoArchive :: Maybe Integer + , -- | Amount of seconds a user has to wait before sending another message + -- (0-21600) + startThreadRateLimit :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON StartThreadOpts where + toJSON StartThreadOpts{..} = objectFromMaybes + [ "name" .== startThreadName + , "auto_archive_duration" .=? startThreadAutoArchive + , "rate_limit_per_user" .=? startThreadRateLimit + ] + +-- | Options for `StartThreadNoMessage` request +data StartThreadNoMessageOpts = StartThreadNoMessageOpts + { -- | Base options for the thread + startThreadNoMessageBaseOpts :: StartThreadOpts + , -- | The type of thread to create + -- + -- Can be @10@, @11@, or @12@. See + -- <https://discord.com/developers/docs/resources/channel#channel-object-channel-types> + startThreadNoMessageType :: Integer + , -- | Whether non-moderators can add other non-moderators to a thread. Only + -- available when creating a private thread. + startThreadNoMessageInvitable :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON StartThreadNoMessageOpts where + toJSON StartThreadNoMessageOpts{..} = objectFromMaybes + [ "name" .== startThreadName startThreadNoMessageBaseOpts + , "auto_archive_duration" .=? startThreadAutoArchive startThreadNoMessageBaseOpts + , "rate_limit_per_user" .=? startThreadRateLimit startThreadNoMessageBaseOpts + , "type" .== startThreadNoMessageType + , "invitable" .=? startThreadNoMessageInvitable + ] + +-- | Result type of `ListJoinedPrivateArchivedThreads`, +-- `ListPrivateArchivedThreads` and `ListPublicArchivedThreads` +data ListThreads = ListThreads + { -- | The returned threads + listThreadsThreads :: [Channel] + , -- | A thread member object for each returned thread the current user has + -- joined + listThreadsMembers :: [ThreadMember] + , -- | Whether there is more data to retrieve + listThreadsHasMore :: Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ListThreads where + toJSON ListThreads{..} = object + [ ("threads", toJSON listThreadsThreads) + , ("members", toJSON listThreadsMembers) + , ("has_more", toJSON listThreadsHasMore) + ] + +instance FromJSON ListThreads where + parseJSON = withObject "ListThreads" $ \o -> + ListThreads <$> o .: "threads" + <*> o .: "members" + <*> o .: "has_more" + +channelMajorRoute :: ChannelRequest a -> String +channelMajorRoute c = case c of + (GetChannel chan) -> "get_chan " <> show chan + (ModifyChannel chan _) -> "mod_chan " <> show chan + (DeleteChannel chan) -> "mod_chan " <> show chan + (GetChannelMessages chan _) -> "msg " <> show chan + (GetChannelMessage (chan, _)) -> "get_msg " <> show chan + (CreateMessage chan _) -> "msg " <> show chan + (CreateMessageDetailed chan _) -> "msg " <> show chan + (CreateReaction (chan, _) _) -> "add_react " <> show chan + (DeleteOwnReaction (chan, _) _) -> "react " <> show chan + (DeleteUserReaction (chan, _) _ _) -> "react " <> show chan + (DeleteSingleReaction (chan, _) _) -> "react " <> show chan + (GetReactions (chan, _) _ _) -> "react " <> show chan + (DeleteAllReactions (chan, _)) -> "react " <> show chan + (EditMessage (chan, _) _) -> "get_msg " <> show chan + (DeleteMessage (chan, _)) -> "get_msg " <> show chan + (BulkDeleteMessage (chan, _)) -> "del_msgs " <> show chan + (EditChannelPermissions chan _ _) -> "perms " <> show chan + (GetChannelInvites chan) -> "invites " <> show chan + (CreateChannelInvite chan _) -> "invites " <> show chan + (DeleteChannelPermission chan _) -> "perms " <> show chan + (TriggerTypingIndicator chan) -> "tti " <> show chan + (GetPinnedMessages chan) -> "pins " <> show chan + (AddPinnedMessage (chan, _)) -> "pin " <> show chan + (DeletePinnedMessage (chan, _)) -> "pin " <> show chan + (GroupDMAddRecipient chan _) -> "groupdm " <> show chan + (GroupDMRemoveRecipient chan _) -> "groupdm " <> show chan + (StartThreadFromMessage chan _ _) -> "thread " <> show chan + (StartThreadNoMessage chan _) -> "thread " <> show chan + (JoinThread chan) -> "thread " <> show chan + (AddThreadMember chan _) -> "thread " <> show chan + (LeaveThread chan) -> "thread " <> show chan + (RemoveThreadMember chan _) -> "thread " <> show chan + (GetThreadMember chan _) -> "thread " <> show chan + (ListThreadMembers chan) -> "thread " <> show chan + (ListPublicArchivedThreads chan _) -> "thread " <> show chan + (ListPrivateArchivedThreads chan _) -> "thread " <> show chan + (ListJoinedPrivateArchivedThreads chan _) -> "thread " <> show chan + +cleanupEmoji :: T.Text -> T.Text +cleanupEmoji emoji = + let noAngles = T.replace "<" "" (T.replace ">" "" emoji) + byName = T.pack <$> unicodeByName (T.unpack (T.replace ":" "" emoji)) + in case (byName, T.stripPrefix ":" noAngles) of + (Just e, _) -> e + (_, Just a) -> "custom:" <> a + (_, Nothing) -> noAngles + +channels :: R.Url 'R.Https +channels = baseUrl /: "channels" + +channelJsonRequest :: ChannelRequest r -> JsonRequest +channelJsonRequest c = case c of + (GetChannel chan) -> + Get (channels /~ chan) mempty + + (ModifyChannel chan patch) -> + Patch (channels /~ chan) (pure (R.ReqBodyJson patch)) mempty + + (DeleteChannel chan) -> + Delete (channels /~ chan) mempty + + (GetChannelMessages chan (n,timing)) -> + let n' = max 1 (min 100 n) + options = "limit" R.=: n' <> messageTimingToQuery timing + in Get (channels /~ chan /: "messages") options + + (GetChannelMessage (chan, msg)) -> + Get (channels /~ chan /: "messages" /~ msg) mempty + + (CreateMessage chan msg) -> + let content = ["content" .= msg] + body = pure $ R.ReqBodyJson $ object content + in Post (channels /~ chan /: "messages") body mempty + + (CreateMessageDetailed chan msgOpts) -> + let fileUpload = messageDetailedFile msgOpts + filePart = + ( case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody + "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] + ) + ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) + + payloadData = objectFromMaybes $ + [ "content" .== messageDetailedContent msgOpts + , "tts" .== messageDetailedTTS msgOpts ] ++ + [ "embeds" .=? ((createEmbed <$>) <$> messageDetailedEmbeds msgOpts) + , "allowed_mentions" .=? messageDetailedAllowedMentions msgOpts + , "message_reference" .=? messageDetailedReference msgOpts + , "components" .=? messageDetailedComponents msgOpts + , "sticker_ids" .=? messageDetailedStickerIds msgOpts + ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) + in Post (channels /~ chan /: "messages") body mempty + + (CreateReaction (chan, msgid) emoji) -> + let e = cleanupEmoji emoji + in Put (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e /: "@me" ) + R.NoReqBody mempty + + (DeleteOwnReaction (chan, msgid) emoji) -> + let e = cleanupEmoji emoji + in Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e /: "@me" ) mempty + + (DeleteUserReaction (chan, msgid) uID emoji) -> + let e = cleanupEmoji emoji + in Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e /~ uID ) mempty + + (DeleteSingleReaction (chan, msgid) emoji) -> + let e = cleanupEmoji emoji + in Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e) mempty + + (GetReactions (chan, msgid) emoji (n, timing)) -> + let e = cleanupEmoji emoji + n' = max 1 (min 100 n) + options = "limit" R.=: n' <> reactionTimingToQuery timing + in Get (channels /~ chan /: "messages" /~ msgid /: "reactions" /: e) options + + (DeleteAllReactions (chan, msgid)) -> + Delete (channels /~ chan /: "messages" /~ msgid /: "reactions" ) mempty + + -- copied from CreateMessageDetailed, should be outsourced to function probably + (EditMessage (chan, msg) msgOpts) -> + let fileUpload = messageDetailedFile msgOpts + filePart = + ( case fileUpload of + Nothing -> [] + Just f -> + [ partFileRequestBody + "file" + (T.unpack $ fst f) + (RequestBodyBS $ snd f) + ] + ) + ++ join (maybe [] (maybeEmbed . Just <$>) (messageDetailedEmbeds msgOpts)) + + payloadData = objectFromMaybes $ + [ "content" .== messageDetailedContent msgOpts + , "tts" .== messageDetailedTTS msgOpts ] ++ + [ "embeds" .=? ((createEmbed <$>) <$> messageDetailedEmbeds msgOpts) + , "allowed_mentions" .=? messageDetailedAllowedMentions msgOpts + , "message_reference" .=? messageDetailedReference msgOpts + , "components" .=? messageDetailedComponents msgOpts + , "sticker_ids" .=? messageDetailedStickerIds msgOpts + ] + payloadPart = partBS "payload_json" $ BL.toStrict $ encode payloadData + + body = R.reqBodyMultipart (payloadPart : filePart) + in Patch (channels /~ chan /: "messages" /~ msg) body mempty + + (DeleteMessage (chan, msg)) -> + Delete (channels /~ chan /: "messages" /~ msg) mempty + + (BulkDeleteMessage (chan, msgs)) -> + let body = pure . R.ReqBodyJson $ object ["messages" .= msgs] + in Post (channels /~ chan /: "messages" /: "bulk-delete") body mempty + + (EditChannelPermissions chan overwriteId (ChannelPermissionsOpts a d)) -> + let body = R.ReqBodyJson $ object [("type", toJSON (either (const 0) (const 1) overwriteId :: Int)) + ,("allow", toJSON a) + ,("deny", toJSON d)] + in Put (channels /~ chan /: "permissions" /~ either unId unId overwriteId) body mempty + + (GetChannelInvites chan) -> + Get (channels /~ chan /: "invites") mempty + + (CreateChannelInvite chan patch) -> + Post (channels /~ chan /: "invites") (pure (R.ReqBodyJson patch)) mempty + + (DeleteChannelPermission chan overwriteId) -> + Delete (channels /~ chan /: "permissions" /~ either unId unId overwriteId) mempty + + (TriggerTypingIndicator chan) -> + Post (channels /~ chan /: "typing") (pure R.NoReqBody) mempty + + (GetPinnedMessages chan) -> + Get (channels /~ chan /: "pins") mempty + + (AddPinnedMessage (chan, msg)) -> + Put (channels /~ chan /: "pins" /~ msg) R.NoReqBody mempty + + (DeletePinnedMessage (chan, msg)) -> + Delete (channels /~ chan /: "pins" /~ msg) mempty + + (GroupDMAddRecipient chan (GroupDMAddRecipientOpts uid nick tok)) -> + Put (channels /~ chan /~ chan /: "recipients" /~ uid) + (R.ReqBodyJson (object [ ("access_token", toJSON tok) + , ("nick", toJSON nick)])) + mempty + + (GroupDMRemoveRecipient chan userid) -> + Delete (channels /~ chan /~ chan /: "recipients" /~ userid) mempty + + (StartThreadFromMessage chan mid sto) -> + Post (channels /~ chan /: "messages" /~ mid /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty + + (StartThreadNoMessage chan sto) -> + Post (channels /~ chan /: "messages" /: "threads") + (pure $ R.ReqBodyJson $ toJSON sto) + mempty + + (JoinThread chan) -> + Put (channels /~ chan /: "thread-members" /: "@me") + R.NoReqBody mempty + + (AddThreadMember chan uid) -> + Put (channels /~ chan /: "thread-members" /~ uid) + R.NoReqBody mempty + + (LeaveThread chan) -> + Delete (channels /~ chan /: "thread-members" /: "@me") + mempty + + (RemoveThreadMember chan uid) -> + Delete (channels /~ chan /: "thread-members" /~ uid) + mempty + + (GetThreadMember chan uid) -> + Get (channels /~ chan /: "thread-members" /~ uid) + mempty + + (ListThreadMembers chan) -> + Get (channels /~ chan /: "thread-members") + mempty + + (ListPublicArchivedThreads chan (time, lim)) -> + Get (channels /~ chan /: "threads" /: "archived" /: "public") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListPrivateArchivedThreads chan (time, lim)) -> + Get (channels /~ chan /: "threads" /: "archived" /: "private") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) + + (ListJoinedPrivateArchivedThreads chan (time, lim)) -> + Get (channels /~ chan /: "users" /: "@me" /: "threads" /: "archived" /: "private") + (maybe mempty ("limit" R.=:) lim <> maybe mempty ("before" R.=:) time) diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs new file mode 100644 index 0000000..2a52171 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Emoji.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Emoji + ( EmojiRequest (..), + ModifyGuildEmojiOpts (..), + parseEmojiImage, + parseStickerImage, + StickerRequest (..), + CreateGuildStickerOpts (..), + EditGuildStickerOpts (..) + ) +where + +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R + +instance Request (EmojiRequest a) where + majorRoute = emojiMajorRoute + jsonRequest = emojiJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data EmojiRequest a where + -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission. + ListGuildEmojis :: GuildId -> EmojiRequest [Emoji] + -- | Emoji object for the given guild and emoji ID + GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji + -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission. + CreateGuildEmoji :: GuildId -> T.Text -> Base64Image Emoji -> EmojiRequest Emoji + -- | Requires MANAGE_EMOJIS permission + ModifyGuildEmoji :: GuildId -> EmojiId -> ModifyGuildEmojiOpts -> EmojiRequest Emoji + -- | Requires MANAGE_EMOJIS permission + DeleteGuildEmoji :: GuildId -> EmojiId -> EmojiRequest () + +data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts + { modifyGuildEmojiName :: T.Text, + modifyGuildEmojiRoles :: [RoleId] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildEmojiOpts where + toJSON (ModifyGuildEmojiOpts name roles) = + object ["name" .= name, "roles" .= roles] + + +-- | @parseEmojiImage bs@ will attempt to convert the given image bytestring @bs@ +-- to the base64 format expected by the Discord API. It may return Left with an +-- error reason if either the bytestring is too large, or if the image format +-- could not be predetermined from the opening few bytes. This function does +-- /not/ validate the rest of the image, nor check that its dimensions are +-- 128x128 as required by Discord. This is up to the library user to check. +-- +-- This function accepts all file types accepted by 'getMimeType'. +parseEmojiImage :: B.ByteString -> Either T.Text (Base64Image Emoji) +parseEmojiImage bs + | B.length bs > 256000 = Left "Cannot create emoji - File is larger than 256kb" + | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs))) + | otherwise = Left "Unsupported image format provided" + +emojiMajorRoute :: EmojiRequest a -> String +emojiMajorRoute c = case c of + (ListGuildEmojis g) -> "emoji " <> show g + (GetGuildEmoji g _) -> "emoji " <> show g + (CreateGuildEmoji g _ _) -> "emoji " <> show g + (ModifyGuildEmoji g _ _) -> "emoji " <> show g + (DeleteGuildEmoji g _) -> "emoji " <> show g + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +emojiJsonRequest :: EmojiRequest r -> JsonRequest +emojiJsonRequest c = case c of + (ListGuildEmojis g) -> Get (guilds /~ g /: "emojis") mempty + (GetGuildEmoji g e) -> Get (guilds /~ g /: "emojis" /~ e) mempty + (CreateGuildEmoji g name b64im) -> + Post + (guilds /~ g /: "emojis") + ( pure + ( R.ReqBodyJson + ( object + [ "name" .= name, + "image" .= b64im + -- todo , "roles" .= ... + ] + ) + ) + ) + mempty + (ModifyGuildEmoji g e o) -> + Patch + (guilds /~ g /: "emojis" /~ e) + (pure (R.ReqBodyJson o)) + mempty + (DeleteGuildEmoji g e) -> Delete (guilds /~ g /: "emojis" /~ e) mempty + +-- | @parseStickerImage bs@ accepts PNG, APNG, or Lottie JSON bytestring @bs@ and +-- will attempt to convert it to the base64 format expected by the Discord API. +-- It may return Left with an error reason if the image format is unexpected. +-- This function does /not/ validate the contents of the image, this is up to +-- the library user to check. +parseStickerImage :: B.ByteString -> Either T.Text (Base64Image Sticker) +parseStickerImage bs + | B.length bs > 512000 + = Left "Cannot create sticker - File is larger than 512kb" + | Just "image/png" <- getMimeType bs + = Right (Base64Image "image/png" (TE.decodeUtf8 (B64.encode bs))) + | not (B.null bs) && B.head bs == 0x7b -- '{' + = Right (Base64Image "application/json" (TE.decodeUtf8 (B64.encode bs))) + | otherwise + = Left "Unsupported image format provided" + +-- | Options for `CreateGuildSticker` +data CreateGuildStickerOpts = CreateGuildStickerOpts + { guildStickerName :: T.Text, + guildStickerDescription :: T.Text, + guildStickerTags :: [T.Text], + guildStickerFile :: Base64Image Sticker + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildStickerOpts where + toJSON (CreateGuildStickerOpts name desc tags b64im) = + object + [ ("name", toJSON name), + ("description", toJSON desc), + ("tags", toJSON $ T.intercalate "," tags), + ("file", toJSON b64im) + ] + +-- | Options for `ModifyGuildSticker` +data EditGuildStickerOpts = EditGuildStickerOpts + { editGuildStickerName :: Maybe T.Text, + editGuildStickerDescription :: Maybe T.Text, + editGuildStickerTags :: Maybe [T.Text] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON EditGuildStickerOpts where + toJSON EditGuildStickerOpts {..} = + objectFromMaybes + [ "name" .=? editGuildStickerName, + "description" .=? editGuildStickerDescription, + "tags" .=? fmap (T.intercalate ",") editGuildStickerTags + ] + +instance Request (StickerRequest a) where + majorRoute = stickerMajorRoute + jsonRequest = stickerJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +-- +-- Be warned that these are untested due to not having a spare server with +-- boosts. Functionality is at your own risk. +data StickerRequest a where + -- | Returns a sticker object for the given sticker ID. + GetSticker :: StickerId -> StickerRequest Sticker + -- | Returns the list of sticker packs available to Nitro subscribers. + ListNitroStickerPacks :: StickerRequest [StickerPack] + -- | Returns an array of sticker objects for the given guild. + ListGuildStickers :: GuildId -> StickerRequest [Sticker] + -- | Returns a sticker object for the given guild and sticker ID. + GetGuildSticker :: GuildId -> StickerId -> StickerRequest Sticker + -- | Create a new sticker for the guild. + CreateGuildSticker :: GuildId -> CreateGuildStickerOpts -> StickerRequest Sticker + -- | Modify a sticker for a guild. + ModifyGuildSticker :: GuildId -> StickerId -> EditGuildStickerOpts -> StickerRequest Sticker + -- | Delete a guild sticker + DeleteGuildSticker :: GuildId -> StickerId -> StickerRequest () + +stickerMajorRoute :: StickerRequest a -> String +stickerMajorRoute = \case + GetSticker gid -> "sticker " <> show gid + ListNitroStickerPacks -> "sticker" + ListGuildStickers gid -> "sticker " <> show gid + GetGuildSticker gid _ -> "sticker " <> show gid + CreateGuildSticker gid _ -> "sticker " <> show gid + ModifyGuildSticker gid _ _ -> "sticker " <> show gid + DeleteGuildSticker gid _ -> "sticker " <> show gid + +stickerJsonRequest :: StickerRequest a -> JsonRequest +stickerJsonRequest = \case + GetSticker gid -> Get (baseUrl /: "stickers" /~ gid) mempty + ListNitroStickerPacks -> Get (baseUrl /: "sticker-packs") mempty + ListGuildStickers gid -> Get (stickersGuild gid) mempty + GetGuildSticker gid sid -> Get (stickersGuild gid /~ sid) mempty + CreateGuildSticker gid cgso -> Post (stickersGuild gid) (pure $ R.ReqBodyJson $ toJSON cgso) mempty + ModifyGuildSticker gid sid egso -> Patch (stickersGuild gid /~ sid) (pure $ R.ReqBodyJson egso) mempty + DeleteGuildSticker gid sid -> Delete (stickersGuild gid /~ sid) mempty + where + stickersGuild gid = baseUrl /: "guilds" /~ gid /: "stickers" diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs new file mode 100644 index 0000000..a0cb3aa --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Guild.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Guild + ( GuildRequest(..) + , CreateGuildChannelOpts(..) + , ModifyGuildOpts(..) + , AddGuildMemberOpts(..) + , ModifyGuildMemberOpts(..) + , GuildMembersTiming(..) + , CreateGuildBanOpts(..) + , ModifyGuildRoleOpts(..) + , CreateGuildIntegrationOpts(..) + , ModifyGuildIntegrationOpts(..) + ) where + + +import Data.Aeson +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R +import qualified Data.Text as T + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types +import Data.Default (Default(..)) + +instance Request (GuildRequest a) where + majorRoute = guildMajorRoute + jsonRequest = guildJsonRequest + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data GuildRequest a where + -- -- Creating a guild with the API is annoying. Do it manually. + -- -- https://discord.com/developers/docs/resources/guild#create-guild + + -- | Returns the new 'Guild' object for the given id + GetGuild :: GuildId -> GuildRequest Guild + -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a + -- Guild Update 'Event'. + ModifyGuild :: GuildId -> ModifyGuildOpts -> GuildRequest Guild + -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'. + DeleteGuild :: GuildId -> GuildRequest () + -- | Returns a list of guild 'Channel' objects + GetGuildChannels :: GuildId -> GuildRequest [Channel] + -- | Create a new 'Channel' object for the guild. Requires 'MANAGE_CHANNELS' + -- permission. Returns the new 'Channel' object on success. Fires a Channel Create + -- 'Event' + CreateGuildChannel :: GuildId -> T.Text -> [Overwrite] -> CreateGuildChannelOpts -> GuildRequest Channel + -- | Modify the positions of a set of channel objects for the guild. Requires + -- 'MANAGE_CHANNELS' permission. Returns a list of all of the guild's 'Channel' + -- objects on success. Fires multiple Channel Update 'Event's. + ModifyGuildChannelPositions :: GuildId -> [(ChannelId,Int)] -> GuildRequest [Channel] + -- | Returns a guild 'Member' object for the specified user + GetGuildMember :: GuildId -> UserId -> GuildRequest GuildMember + -- | Returns a list of guild 'Member' objects that are members of the guild. + ListGuildMembers :: GuildId -> GuildMembersTiming -> GuildRequest [GuildMember] + -- | Adds a user to the guild, provided you have a valid oauth2 access token + -- for the user with the guilds.join scope. Returns the guild 'Member' as the body. + -- Fires a Guild Member Add 'Event'. Requires the bot to have the + -- CREATE_INSTANT_INVITE permission. + AddGuildMember :: GuildId -> UserId -> AddGuildMemberOpts + -> GuildRequest () + -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'. + ModifyGuildMember :: GuildId -> UserId -> ModifyGuildMemberOpts -> GuildRequest GuildMember + -- | Modify the nickname of the current user + ModifyCurrentUserNick :: GuildId -> T.Text -> GuildRequest () + -- | Add a member to a guild role. Requires 'MANAGE_ROLES' permission. + AddGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest () + -- | Remove a member from a guild role. Requires 'MANAGE_ROLES' permission. + RemoveGuildMemberRole :: GuildId -> UserId -> RoleId -> GuildRequest () + -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a + -- Guild Member Remove 'Event'. + RemoveGuildMember :: GuildId -> UserId -> GuildRequest () + -- | Returns a list of 'Ban' objects for users that are banned from this guild. Requires the + -- 'BAN_MEMBERS' permission + GetGuildBans :: GuildId -> GuildRequest [GuildBan] + -- | Returns a 'Ban' object for the user banned from this guild. Requires the + -- 'BAN_MEMBERS' permission + GetGuildBan :: GuildId -> UserId -> GuildRequest GuildBan + -- | Create a guild ban, and optionally Delete previous messages sent by the banned + -- user. Requires the 'BAN_MEMBERS' permission. Fires a Guild Ban Add 'Event'. + CreateGuildBan :: GuildId -> UserId -> CreateGuildBanOpts -> GuildRequest () + -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions. + -- Fires a Guild Ban Remove 'Event'. + RemoveGuildBan :: GuildId -> UserId -> GuildRequest () + -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES' + -- permission + GetGuildRoles :: GuildId -> GuildRequest [Role] + -- | Create a new 'Role' for the guild. Requires the 'MANAGE_ROLES' permission. + -- Returns the new role object on success. Fires a Guild Role Create 'Event'. + CreateGuildRole :: GuildId -> ModifyGuildRoleOpts -> GuildRequest Role + -- | Modify the positions of a set of role objects for the guild. Requires the + -- 'MANAGE_ROLES' permission. Returns a list of all of the guild's 'Role' objects + -- on success. Fires multiple Guild Role Update 'Event's. + ModifyGuildRolePositions :: GuildId -> [(RoleId, Integer)] -> GuildRequest [Role] + -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the + -- updated 'Role' on success. Fires a Guild Role Update 'Event's. + ModifyGuildRole :: GuildId -> RoleId -> ModifyGuildRoleOpts -> GuildRequest Role + -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role + -- Delete 'Event'. + DeleteGuildRole :: GuildId -> RoleId -> GuildRequest () + -- | Returns an object with one 'pruned' key indicating the number of members + -- that would be removed in a prune operation. Requires the 'KICK_MEMBERS' + -- permission. + GetGuildPruneCount :: GuildId -> Integer -> GuildRequest Object + -- | Begin a prune operation. Requires the 'KICK_MEMBERS' permission. Returns an + -- object with one 'pruned' key indicating the number of members that were removed + -- in the prune operation. Fires multiple Guild Member Remove 'Events'. + BeginGuildPrune :: GuildId -> Integer -> GuildRequest Object + -- | Returns a list of 'VoiceRegion' objects for the guild. Unlike the similar /voice + -- route, this returns VIP servers when the guild is VIP-enabled. + GetGuildVoiceRegions :: GuildId -> GuildRequest [VoiceRegion] + -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD' + -- permission. + GetGuildInvites :: GuildId -> GuildRequest [Invite] + -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD' + -- permission. + GetGuildIntegrations :: GuildId -> GuildRequest [Integration] + -- | Attach an 'Integration' object from the current user to the guild. Requires the + -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + CreateGuildIntegration :: GuildId -> IntegrationId -> CreateGuildIntegrationOpts -> GuildRequest () + -- | Modify the behavior and settings of a 'Integration' object for the guild. + -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + ModifyGuildIntegration :: GuildId -> IntegrationId -> ModifyGuildIntegrationOpts + -> GuildRequest () + -- | Delete the attached 'Integration' object for the guild. Requires the + -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'. + DeleteGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () + -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission. + SyncGuildIntegration :: GuildId -> IntegrationId -> GuildRequest () + -- | Returns the 'GuildWidget' object. Requires the 'MANAGE_GUILD' permission. + GetGuildWidget :: GuildId -> GuildRequest GuildWidget + -- | Modify a 'GuildWidget' object for the guild. All attributes may be passed in with + -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated + -- 'GuildWidget' object. + ModifyGuildWidget :: GuildId -> GuildWidget -> GuildRequest GuildWidget + -- | Vanity URL + GetGuildVanityURL :: GuildId -> GuildRequest T.Text + +-- | Options for `ModifyGuildIntegration` +data ModifyGuildIntegrationOpts = ModifyGuildIntegrationOpts + { modifyGuildIntegrationOptsExpireBehavior :: Integer + , modifyGuildIntegrationOptsExpireGraceSeconds :: Integer + , modifyGuildIntegrationOptsEmoticonsEnabled :: Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildIntegrationOpts where + toJSON ModifyGuildIntegrationOpts{..} = objectFromMaybes + [ "expire_grace_period" .== modifyGuildIntegrationOptsExpireGraceSeconds + , "expire_behavior" .== modifyGuildIntegrationOptsExpireBehavior + , "enable_emoticons" .== modifyGuildIntegrationOptsEmoticonsEnabled ] + +-- | Options for `CreateGuildIntegration` +newtype CreateGuildIntegrationOpts = CreateGuildIntegrationOpts + { createGuildIntegrationOptsType :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildIntegrationOpts where + toJSON CreateGuildIntegrationOpts{..} = objectFromMaybes + ["type" .== createGuildIntegrationOptsType] + +-- | Options for `CreateGuildBan` +data CreateGuildBanOpts = CreateGuildBanOpts + { createGuildBanOptsDeleteLastNMessages :: Maybe Int + , createGuildBanOptsReason :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateGuildBanOpts where + toJSON CreateGuildBanOpts{..} = objectFromMaybes + [ "delete_message_days" + .=? createGuildBanOptsDeleteLastNMessages + , "reason" .=? createGuildBanOptsReason] + +-- | Options for `ModifyGuildRole` +data ModifyGuildRoleOpts = ModifyGuildRoleOpts + { modifyGuildRoleOptsName :: Maybe T.Text + , modifyGuildRoleOptsPermissions :: Maybe RolePermissions + , modifyGuildRoleOptsColor :: Maybe DiscordColor + , modifyGuildRoleOptsSeparateSidebar :: Maybe Bool + , modifyGuildRoleOptsMentionable :: Maybe Bool + , modifyGuildRoleOptsIcon :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildRoleOpts where + toJSON ModifyGuildRoleOpts{..} = objectFromMaybes + ["name" .=? modifyGuildRoleOptsName, + "permissions" .=? modifyGuildRoleOptsPermissions, + "color" .=? modifyGuildRoleOptsColor, + "hoist" .=? modifyGuildRoleOptsSeparateSidebar, + "mentionable" .=? modifyGuildRoleOptsMentionable, + "icon" .=? modifyGuildRoleOptsIcon] + +-- | Options for `AddGuildMember` +data AddGuildMemberOpts = AddGuildMemberOpts + { addGuildMemberOptsAccessToken :: T.Text + , addGuildMemberOptsNickname :: Maybe T.Text + , addGuildMemberOptsRoles :: Maybe [RoleId] + , addGuildMemberOptsIsMuted :: Maybe Bool + , addGuildMemberOptsIsDeafened :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON AddGuildMemberOpts where + toJSON AddGuildMemberOpts{..} = objectFromMaybes + ["access_token" .== addGuildMemberOptsAccessToken, + "nick" .=? addGuildMemberOptsNickname, + "roles" .=? addGuildMemberOptsRoles, + "mute" .=? addGuildMemberOptsIsMuted, + "deaf" .=? addGuildMemberOptsIsDeafened] + +-- | Options for `ModifyGuildMember` +data ModifyGuildMemberOpts = ModifyGuildMemberOpts + { modifyGuildMemberOptsNickname :: Maybe T.Text + , modifyGuildMemberOptsRoles :: Maybe [RoleId] + , modifyGuildMemberOptsIsMuted :: Maybe Bool + , modifyGuildMemberOptsIsDeafened :: Maybe Bool + , modifyGuildMemberOptsMoveToChannel :: Maybe ChannelId + , modifyGuildMemberOptsTimeoutUntil :: Maybe (Maybe UTCTime) -- ^ If `Just Nothing`, the timeout will be removed. + } deriving (Show, Read, Eq, Ord) + +instance Default ModifyGuildMemberOpts where + def = ModifyGuildMemberOpts Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON ModifyGuildMemberOpts where + toJSON ModifyGuildMemberOpts{..} = objectFromMaybes + ["nick" .=? modifyGuildMemberOptsNickname, + "roles" .=? modifyGuildMemberOptsRoles, + "mute" .=? modifyGuildMemberOptsIsMuted, + "deaf" .=? modifyGuildMemberOptsIsDeafened, + "channel_id" .=? modifyGuildMemberOptsMoveToChannel, + "communication_disabled_until" .=? modifyGuildMemberOptsTimeoutUntil] + +-- | Options for `CreateGuildChannel` +data CreateGuildChannelOpts + -- | Create a text channel + = CreateGuildChannelOptsText { + createGuildChannelOptsTopic :: Maybe T.Text + , createGuildChannelOptsUserMessageRateDelay :: Maybe Integer + , createGuildChannelOptsIsNSFW :: Maybe Bool + , createGuildChannelOptsCategoryId :: Maybe ChannelId } + -- | Create a voice channel + | CreateGuildChannelOptsVoice { + createGuildChannelOptsBitrate :: Maybe Integer + , createGuildChannelOptsMaxUsers :: Maybe Integer + , createGuildChannelOptsCategoryId :: Maybe ChannelId } + -- | Create a category + | CreateGuildChannelOptsCategory + deriving (Show, Read, Eq, Ord) + +-- | Converts a channel name, a list of permissions and other channel options into a JSON Value +createChannelOptsToJSON :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value +createChannelOptsToJSON name perms opts = objectFromMaybes optsJSON + where + optsJSON = case opts of + CreateGuildChannelOptsText{..} -> + ["name" .== String name + ,"type" .== Number 0 + ,"permission_overwrites" .== perms + ,"topic" .=? createGuildChannelOptsTopic + ,"rate_limit_per_user" .=? createGuildChannelOptsUserMessageRateDelay + ,"nsfw" .=? createGuildChannelOptsIsNSFW + ,"parent_id" .=? createGuildChannelOptsCategoryId] + CreateGuildChannelOptsVoice{..} -> + ["name" .== String name + ,"type" .== Number 2 + ,"permission_overwrites" .== perms + ,"bitrate" .=? createGuildChannelOptsBitrate + ,"user_limit" .=? createGuildChannelOptsMaxUsers + ,"parent_id" .=? createGuildChannelOptsCategoryId] + CreateGuildChannelOptsCategory -> + ["name" .== String name + ,"type" .== Number 4 + ,"permission_overwrites" .== perms] + + +-- | Options for `ModifyGuild` +-- +-- See <https://discord.com/developers/docs/resources/guild#modify-guild> +data ModifyGuildOpts = ModifyGuildOpts + { modifyGuildOptsName :: Maybe T.Text + , modifyGuildOptsAFKChannelId :: Maybe ChannelId + , modifyGuildOptsIcon :: Maybe T.Text + , modifyGuildOptsOwnerId :: Maybe UserId + -- Region + -- VerificationLevel + -- DefaultMessageNotification + -- ExplicitContentFilter + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyGuildOpts where + toJSON ModifyGuildOpts{..} = objectFromMaybes + ["name" .=? modifyGuildOptsName, + "afk_channel_id" .=? modifyGuildOptsAFKChannelId, + "icon" .=? modifyGuildOptsIcon, + "owner_id" .=? modifyGuildOptsOwnerId] + +data GuildMembersTiming = GuildMembersTiming + { guildMembersTimingLimit :: Maybe Int + , guildMembersTimingAfter :: Maybe UserId + } deriving (Show, Read, Eq, Ord) + +guildMembersTimingToQuery :: GuildMembersTiming -> R.Option 'R.Https +guildMembersTimingToQuery (GuildMembersTiming mLimit mAfter) = + let limit = case mLimit of + Nothing -> mempty + Just lim -> "limit" R.=: lim + after = case mAfter of + Nothing -> mempty + Just aft -> "after" R.=: show aft + in limit <> after + +guildMajorRoute :: GuildRequest a -> String +guildMajorRoute c = case c of + (GetGuild g) -> "guild " <> show g + (ModifyGuild g _) -> "guild " <> show g + (DeleteGuild g) -> "guild " <> show g + (GetGuildChannels g) -> "guild_chan " <> show g + (CreateGuildChannel g _ _ _) -> "guild_chan " <> show g + (ModifyGuildChannelPositions g _) -> "guild_chan " <> show g + (GetGuildMember g _) -> "guild_memb " <> show g + (ListGuildMembers g _) -> "guild_membs " <> show g + (AddGuildMember g _ _) -> "guild_membs " <> show g + (ModifyGuildMember g _ _) -> "guild_membs " <> show g + (ModifyCurrentUserNick g _) -> "guild_membs " <> show g + (AddGuildMemberRole g _ _) -> "guild_membs " <> show g + (RemoveGuildMemberRole g _ _) -> "guild_membs " <> show g + (RemoveGuildMember g _) -> "guild_membs " <> show g + (GetGuildBan g _) -> "guild_bans " <> show g + (GetGuildBans g) -> "guild_bans " <> show g + (CreateGuildBan g _ _) -> "guild_ban " <> show g + (RemoveGuildBan g _) -> "guild_ban " <> show g + (GetGuildRoles g) -> "guild_roles " <> show g + (CreateGuildRole g _) -> "guild_roles " <> show g + (ModifyGuildRolePositions g _) -> "guild_roles " <> show g + (ModifyGuildRole g _ _) -> "guild_role " <> show g + (DeleteGuildRole g _) -> "guild_role " <> show g + (GetGuildPruneCount g _) -> "guild_prune " <> show g + (BeginGuildPrune g _) -> "guild_prune " <> show g + (GetGuildVoiceRegions g) -> "guild_voice " <> show g + (GetGuildInvites g) -> "guild_invit " <> show g + (GetGuildIntegrations g) -> "guild_integ " <> show g + (CreateGuildIntegration g _ _) -> "guild_integ " <> show g + (ModifyGuildIntegration g _ _) -> "guild_intgr " <> show g + (DeleteGuildIntegration g _) -> "guild_intgr " <> show g + (SyncGuildIntegration g _) -> "guild_sync " <> show g + (GetGuildWidget g) -> "guild_widget " <> show g + (ModifyGuildWidget g _) -> "guild_widget " <> show g + (GetGuildVanityURL g) -> "guild " <> show g + + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +guildJsonRequest :: GuildRequest r -> JsonRequest +guildJsonRequest c = case c of + (GetGuild guild) -> + Get (guilds /~ guild) mempty + + (ModifyGuild guild patch) -> + Patch (guilds /~ guild) (pure (R.ReqBodyJson patch)) mempty + + (DeleteGuild guild) -> + Delete (guilds /~ guild) mempty + + (GetGuildChannels guild) -> + Get (guilds /~ guild /: "channels") mempty + + (CreateGuildChannel guild name perms patch) -> + Post (guilds /~ guild /: "channels") + (pure (R.ReqBodyJson (createChannelOptsToJSON name perms patch))) mempty + + (ModifyGuildChannelPositions guild newlocs) -> + let patch = map (\(a, b) -> object [("id", toJSON a) + ,("position", toJSON b)]) newlocs + in Patch (guilds /~ guild /: "channels") (pure (R.ReqBodyJson patch)) mempty + + (GetGuildMember guild member) -> + Get (guilds /~ guild /: "members" /~ member) mempty + + (ListGuildMembers guild range) -> + Get (guilds /~ guild /: "members") (guildMembersTimingToQuery range) + + (AddGuildMember guild user patch) -> + Put (guilds /~ guild /: "members" /~ user) (R.ReqBodyJson patch) mempty + + (ModifyGuildMember guild member patch) -> + Patch (guilds /~ guild /: "members" /~ member) (pure (R.ReqBodyJson patch)) mempty + + (ModifyCurrentUserNick guild name) -> + let patch = object ["nick" .= name] + in Patch (guilds /~ guild /: "members/@me/nick") (pure (R.ReqBodyJson patch)) mempty + + (AddGuildMemberRole guild user role) -> + let body = R.ReqBodyJson (object []) + in Put (guilds /~ guild /: "members" /~ user /: "roles" /~ role) body mempty + + (RemoveGuildMemberRole guild user role) -> + Delete (guilds /~ guild /: "members" /~ user /: "roles" /~ role) mempty + + (RemoveGuildMember guild user) -> + Delete (guilds /~ guild /: "members" /~ user) mempty + + (GetGuildBan guild user) -> Get (guilds /~ guild /: "bans" /~ user) mempty + + (GetGuildBans guild) -> Get (guilds /~ guild /: "bans") mempty + + (CreateGuildBan guild user patch) -> + Put (guilds /~ guild /: "bans" /~ user) (R.ReqBodyJson patch) mempty + + (RemoveGuildBan guild ban) -> + Delete (guilds /~ guild /: "bans" /~ ban) mempty + + (GetGuildRoles guild) -> + Get (guilds /~ guild /: "roles") mempty + + (CreateGuildRole guild patch) -> + Post (guilds /~ guild /: "roles") (pure (R.ReqBodyJson patch)) mempty + + (ModifyGuildRolePositions guild patch) -> + let body = map (\(role, pos) -> object ["id".=role, "position".=pos]) patch + in Patch (guilds /~ guild /: "roles") (pure (R.ReqBodyJson body)) mempty + + (ModifyGuildRole guild role patch) -> + Patch (guilds /~ guild /: "roles" /~ role) (pure (R.ReqBodyJson patch)) mempty + + (DeleteGuildRole guild role) -> + Delete (guilds /~ guild /: "roles" /~ role) mempty + + (GetGuildPruneCount guild days) -> + Get (guilds /~ guild /: "prune") ("days" R.=: days) + + (BeginGuildPrune guild days) -> + Post (guilds /~ guild /: "prune") (pure R.NoReqBody) ("days" R.=: days) + + (GetGuildVoiceRegions guild) -> + Get (guilds /~ guild /: "regions") mempty + + (GetGuildInvites guild) -> + Get (guilds /~ guild /: "invites") mempty + + (GetGuildIntegrations guild) -> + Get (guilds /~ guild /: "integrations") mempty + + (CreateGuildIntegration guild iid opts) -> + let patch = object ["type" .= createGuildIntegrationOptsType opts, "id" .= iid] + in Post (guilds /~ guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty + + (ModifyGuildIntegration guild iid patch) -> + let body = pure (R.ReqBodyJson patch) + in Patch (guilds /~ guild /: "integrations" /~ iid) body mempty + + (DeleteGuildIntegration guild integ) -> + Delete (guilds /~ guild /: "integrations" /~ integ) mempty + + (SyncGuildIntegration guild integ) -> + Post (guilds /~ guild /: "integrations" /~ integ) (pure R.NoReqBody) mempty + + (GetGuildWidget guild) -> + Get (guilds /~ guild /: "integrations") mempty + + (ModifyGuildWidget guild patch) -> + Patch (guilds /~ guild /: "widget") (pure (R.ReqBodyJson patch)) mempty + + (GetGuildVanityURL guild) -> + Get (guilds /~ guild /: "vanity-url") mempty + diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/HTTP.hs b/deps/discord-haskell/src/Discord/Internal/Rest/HTTP.hs new file mode 100644 index 0000000..f9c0341 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/HTTP.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Provide HTTP primitives +module Discord.Internal.Rest.HTTP + ( restLoop + , Request(..) + , JsonRequest(..) + , RestCallInternalException(..) + ) where + +import Prelude hiding (log) + +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent (threadDelay) +import Control.Exception.Safe (try) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.Ix (inRange) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) +import qualified Network.HTTP.Req as R +import qualified Data.Map.Strict as M + +import Discord.Internal.Types +import Discord.Internal.Rest.Prelude + +-- | An exception in a Rest call +data RestCallInternalException + -- | Error code from Discord + = RestCallInternalErrorCode Int B.ByteString B.ByteString + -- | Couldn't parse the response + | RestCallInternalNoParse String BL.ByteString + -- | Something went bad in the HTTP process + | RestCallInternalHttpException R.HttpException + deriving (Show) + +-- | Rest event loop +restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) + -> Chan T.Text -> IO () +restLoop auth urls log = loop M.empty + where + loop ratelocker = do + threadDelay (40 * 1000) + (route, request, thread) <- readChan urls + curtime <- getPOSIXTime + case compareRate ratelocker route curtime of + Locked -> do writeChan urls (route, request, thread) + loop ratelocker + Available -> do let action = compileRequest auth request + reqIO <- try $ restIOtoIO (tryRequest log action) + case reqIO :: Either R.HttpException (RequestResponse, Timeout) of + Left e -> do + writeChan log ("rest - http exception " <> T.pack (show e)) + putMVar thread (Left (RestCallInternalHttpException e)) + loop ratelocker + Right (resp, retry) -> do + case resp of + -- decode "[]" == () for expected empty calls + ResponseByteString "" -> putMVar thread (Right "[]") + ResponseByteString bs -> putMVar thread (Right bs) + ResponseErrorCode e s b -> + putMVar thread (Left (RestCallInternalErrorCode e s b)) + ResponseTryAgain -> writeChan urls (route, request, thread) + case retry of + GlobalWait i -> do + writeChan log ("rest - GLOBAL WAIT LIMIT: " + <> T.pack (show ((i - curtime) * 1000))) + threadDelay $ round ((i - curtime + 0.1) * 1000) + loop ratelocker + PathWait i -> loop $ M.insert route i (removeAllExpire ratelocker curtime) + NoLimit -> loop ratelocker + +data RateLimited = Available | Locked + +compareRate :: M.Map String POSIXTime -> String -> POSIXTime -> RateLimited +compareRate ratelocker route curtime = + case M.lookup route ratelocker of + Just unlockTime -> if curtime < unlockTime then Locked else Available + Nothing -> Available + +removeAllExpire :: M.Map String POSIXTime -> POSIXTime -> M.Map String POSIXTime +removeAllExpire ratelocker curtime = + if M.size ratelocker > 100 then M.filter (> curtime) ratelocker + else ratelocker + +data RequestResponse = ResponseTryAgain + | ResponseByteString BL.ByteString + | ResponseErrorCode Int B.ByteString B.ByteString + deriving (Show) + +data Timeout = GlobalWait POSIXTime + | PathWait POSIXTime + | NoLimit + +tryRequest :: Chan T.Text -> RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout) +tryRequest _log action = do + resp <- action + now <- liftIO getPOSIXTime + let body = R.responseBody resp + code = R.responseStatusCode resp + status = R.responseStatusMessage resp + global = (Just ("true" :: String) ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global" + remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining" :: Integer + reset = withDelta . fromMaybe 10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset-After" + + withDelta :: Double -> POSIXTime + withDelta dt = now + fromRational (toRational dt) + + if | code == 429 -> pure (ResponseTryAgain, if global then GlobalWait reset + else PathWait reset) + | code `elem` [500,502] -> pure (ResponseTryAgain, NoLimit) + | inRange (200,299) code -> pure ( ResponseByteString body + , if remain > 0 then NoLimit else PathWait reset ) + | inRange (400,499) code -> pure (ResponseErrorCode code status (BL.toStrict body) + , if remain > 0 then NoLimit else PathWait reset ) + | otherwise -> pure (ResponseErrorCode code status (BL.toStrict body), NoLimit) + +readMaybeBS :: Read a => B.ByteString -> Maybe a +readMaybeBS = readMaybe . T.unpack . TE.decodeUtf8 + +compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse +compileRequest auth request = action + where + authopt = authHeader auth <> R.header "X-RateLimit-Precision" "millisecond" + + action = case request of + (Delete url opts) -> R.req R.DELETE url R.NoReqBody R.lbsResponse (authopt <> opts) + (Get url opts) -> R.req R.GET url R.NoReqBody R.lbsResponse (authopt <> opts) + (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) + (Patch url body opts) -> do b <- body + R.req R.PATCH url b R.lbsResponse (authopt <> opts) + (Post url body opts) -> do b <- body + R.req R.POST url b R.lbsResponse (authopt <> opts) diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Interactions.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Interactions.hs new file mode 100644 index 0000000..44e41d1 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Interactions.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Rest.Interactions (InteractionResponseRequest(..)) where + +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BL +import Discord.Internal.Rest.Prelude + ( RestIO, + Request(..), + JsonRequest(Delete, Post, Get, Patch), + baseUrl) +import Discord.Internal.Types +import Discord.Internal.Types.Interactions +import Network.HTTP.Client.MultipartFormData (PartM, partBS) +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R + +-- | Data constructor for Interaction response requests +data InteractionResponseRequest a where + -- | Create a response to an Interaction from the gateway. + -- + -- This endpoint also supports file attachments similar to the webhook endpoints. + -- Refer to [Uploading files](https://discord.com/developers/docs/reference#uploading-files) + -- for details on uploading files and @multipart/form-data@ requests. + CreateInteractionResponse :: InteractionId -> InteractionToken -> InteractionResponse -> InteractionResponseRequest () + -- | Returns the initial Interaction response. + GetOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest Message + -- | Edits the initial Interaction response. + EditOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message + -- | Deletes the initial Interaction response. + DeleteOriginalInteractionResponse :: ApplicationId -> InteractionToken -> InteractionResponseRequest () + -- | Create a followup message for an Interaction + CreateFollowupInteractionMessage :: ApplicationId -> InteractionToken -> InteractionResponseMessage -> InteractionResponseRequest Message + -- | Returns a followup message for an Interaction. + GetFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest Message + -- | Edits a followup message for an Interaction. + EditFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponse -> InteractionResponseRequest Message + -- | Deletes a followup message for an Interaction. + DeleteFollowupInteractionMessage :: ApplicationId -> InteractionToken -> MessageId -> InteractionResponseRequest () + +instance Request (InteractionResponseRequest a) where + jsonRequest = interactionResponseJsonRequest + majorRoute = interactionResponseMajorRoute + +interactionResponseMajorRoute :: InteractionResponseRequest a -> String +interactionResponseMajorRoute a = case a of + (CreateInteractionResponse iid _ _) -> "intresp " <> show iid + (GetOriginalInteractionResponse aid _) -> "intresp " <> show aid + (EditOriginalInteractionResponse aid _ _) -> "intresp " <> show aid + (DeleteOriginalInteractionResponse aid _) -> "intresp " <> show aid + (CreateFollowupInteractionMessage iid _ _) -> "intrespf " <> show iid + (GetFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + (EditFollowupInteractionMessage aid _ _ _) -> "intrespf " <> show aid + (DeleteFollowupInteractionMessage aid _ _) -> "intrespf " <> show aid + +interaction :: ApplicationId -> InteractionToken -> R.Url 'R.Https +interaction aid it = baseUrl /: "webhooks" /~ aid /~ it /: "messages" + +interactionResponseJsonRequest :: InteractionResponseRequest a -> JsonRequest +interactionResponseJsonRequest a = case a of + (CreateInteractionResponse iid it i) -> + Post (baseUrl /: "interactions" /~ iid /~ it /: "callback") (convert i) mempty + (GetOriginalInteractionResponse aid it) -> + Get (interaction aid it /: "@original") mempty + (EditOriginalInteractionResponse aid it i) -> + Patch (interaction aid it /: "@original") (convertIRM i) mempty + (DeleteOriginalInteractionResponse aid it) -> + Delete (interaction aid it /: "@original") mempty + (CreateFollowupInteractionMessage aid it i) -> + Post (baseUrl /: "webhooks" /~ aid /~ it) (convertIRM i) mempty + (GetFollowupInteractionMessage aid it mid) -> + Get (interaction aid it /~ mid) mempty + (EditFollowupInteractionMessage aid it mid i) -> + Patch (interaction aid it /~ mid) (convert i) mempty + (DeleteFollowupInteractionMessage aid it mid) -> + Delete (interaction aid it /~ mid) mempty + where + convert :: InteractionResponse -> RestIO R.ReqBodyMultipart + convert ir@(InteractionResponseChannelMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir@(InteractionResponseUpdateMessage irm) = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode ir) : convert' irm) + convert ir = R.reqBodyMultipart [partBS "payload_json" $ BL.toStrict $ encode ir] + convertIRM :: InteractionResponseMessage -> RestIO R.ReqBodyMultipart + convertIRM irm = R.reqBodyMultipart (partBS "payload_json" (BL.toStrict $ encode irm) : convert' irm) + convert' :: InteractionResponseMessage -> [PartM IO] + convert' InteractionResponseMessage {..} = case interactionResponseMessageEmbeds of + Nothing -> [] + Just f -> (maybeEmbed . Just) =<< f diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Invite.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Invite.hs new file mode 100644 index 0000000..79b4aa5 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Invite.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Invite + ( InviteRequest(..) + ) where + +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R +import qualified Data.Text as T + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (InviteRequest a) where + majorRoute = inviteMajorRoute + jsonRequest = inviteJsonRequest + + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data InviteRequest a where + -- | Get invite for given code + GetInvite :: T.Text -> InviteRequest Invite + -- | Delete invite by code + DeleteInvite :: T.Text -> InviteRequest Invite + +inviteMajorRoute :: InviteRequest a -> String +inviteMajorRoute c = case c of + (GetInvite _) -> "invite " + (DeleteInvite _) -> "invite " + +invite :: R.Url 'R.Https +invite = baseUrl /: "invites" + +inviteJsonRequest :: InviteRequest r -> JsonRequest +inviteJsonRequest c = case c of + (GetInvite g) -> Get (invite R./: g) mempty + (DeleteInvite g) -> Delete (invite R./: g) mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Prelude.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Prelude.hs new file mode 100644 index 0000000..4b7d825 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Prelude.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | Utility and base types and functions for the Discord Rest API +module Discord.Internal.Rest.Prelude where + +import Prelude hiding (log) +import Control.Exception.Safe (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.String (IsString(fromString)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import qualified Network.HTTP.Req as R +import Web.Internal.HttpApiData (ToHttpApiData) + +import Discord.Internal.Types + +import Paths_discord_haskell (version) +import Data.Version (showVersion) + +-- | The api version to use. +apiVersion :: T.Text +apiVersion = "10" + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discord.com" R./: "api" R./: apiVersion' + where apiVersion' = "v" <> apiVersion + +-- | Discord requires HTTP headers for authentication. +authHeader :: Auth -> R.Option 'R.Https +authHeader auth = + R.header "Authorization" (TE.encodeUtf8 (authToken auth)) + <> R.header "User-Agent" agent + where + -- | https://discord.com/developers/docs/reference#user-agent + -- Second place where the library version is noted + agent = fromString $ "DiscordBot (https://github.com/discord-haskell/discord-haskell, " <> showVersion version <> ")" + +-- Possibly append to an URL +infixl 5 /? +(/?) :: ToHttpApiData a => R.Url scheme -> Maybe a -> R.Url scheme +(/?) url Nothing = url +(/?) url (Just part) = url R./~ part + + +-- | A compiled HTTP request ready to execute +data JsonRequest where + Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Put :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest + Patch :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + Post :: R.HttpBody a => R.Url 'R.Https -> RestIO a -> R.Option 'R.Https -> JsonRequest + +class Request a where + -- | used for putting a request into a rate limit bucket + -- https://discord.com/developers/docs/topics/rate-limits#rate-limits + majorRoute :: a -> String + + -- | build a JSON http request + jsonRequest :: a -> JsonRequest + +-- | Same Monad as IO. Overwrite Req settings +newtype RestIO a = RestIO { restIOtoIO :: IO a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance R.MonadHttp RestIO where + -- | Throw actual exceptions + handleHttpException = liftIO . throwIO + -- | Don't throw exceptions on http error codes like 404 + getHttpConfig = pure $ R.defaultHttpConfig { R.httpConfigCheckResponse = \_ _ _ -> Nothing } diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/ScheduledEvents.hs b/deps/discord-haskell/src/Discord/Internal/Rest/ScheduledEvents.hs new file mode 100644 index 0000000..bb35d12 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/ScheduledEvents.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Scheduled Event API +module Discord.Internal.Rest.ScheduledEvents + ( ScheduledEventRequest(..) + ) where +import Data.Aeson ( ToJSON(toJSON) ) +import Discord.Internal.Rest.Prelude ( JsonRequest(..) + , Request + ( jsonRequest + , majorRoute + ) + , baseUrl + ) +import Discord.Internal.Types.Prelude ( GuildId + , ScheduledEventId + ) +import Discord.Internal.Types.ScheduledEvents + ( CreateScheduledEventData + , ModifyScheduledEventData + , ScheduledEvent + , ScheduledEventUser + ) +import qualified Network.HTTP.Req as R +import Network.HTTP.Req ( (/:), (/~) ) + +-- | Data constructor for requests. +-- See <https://discord.com/developers/docs/resources/guild-scheduled-event> +data ScheduledEventRequest a where + -- | Gets all the Scheduled Events of a Guild + ListScheduledEvents ::GuildId + -> ScheduledEventRequest [ScheduledEvent] + -- | Creates a new ScheduledEvent + CreateScheduledEvent ::GuildId + -> CreateScheduledEventData + -> ScheduledEventRequest ScheduledEvent + -- | Gets the information about an Event + GetScheduledEvent ::GuildId + -> ScheduledEventId + -> ScheduledEventRequest ScheduledEvent + -- | Modifies a Scheduled Event's information + ModifyScheduledEvent ::GuildId + -> ScheduledEventId + -> ModifyScheduledEventData + -> ScheduledEventRequest ScheduledEvent + -- | Delete a ScheduledEvent + DeleteScheduledEvent ::GuildId + -> ScheduledEventId + -> ScheduledEventRequest () + -- | Gets the Users that subscribed to the event + GetScheduledEventUsers ::GuildId + -> ScheduledEventId + -> ScheduledEventRequest [ScheduledEventUser] + +sevEndpoint :: GuildId -> R.Url 'R.Https +sevEndpoint gid = baseUrl /: "guilds" /~ gid /: "scheduled-events" + +instance Request (ScheduledEventRequest a) where + majorRoute = const "scheduledEvent" + jsonRequest rq = case rq of + ListScheduledEvents gid -> Get (sevEndpoint gid) mempty + GetScheduledEvent gid ev -> Get (sevEndpoint gid /~ ev) mempty + CreateScheduledEvent gid ev -> + Post (sevEndpoint gid) (pure $ R.ReqBodyJson $ toJSON ev) mempty + ModifyScheduledEvent gid evi ev -> Patch + (sevEndpoint gid /~ evi) + (pure $ R.ReqBodyJson $ toJSON ev) + mempty + DeleteScheduledEvent gid evi -> Delete (sevEndpoint gid /~ evi) mempty + GetScheduledEventUsers gid evi -> + Get (sevEndpoint gid /~ evi /: "users") mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/User.hs b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs new file mode 100644 index 0000000..28c0505 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/User.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.User + ( UserRequest(..) + , parseAvatarImage + ) where + + +import Data.Aeson +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (UserRequest a) where + majorRoute = userMajorRoute + jsonRequest = userJsonRequest + + +-- | Data constructor for requests. See <https://discord.com/developers/docs/resources/ API> +data UserRequest a where + -- | Returns the 'User' object of the requester's account. For OAuth2, this requires + -- the identify scope, which will return the object without an email, and optionally + -- the email scope, which returns the object with an email. + GetCurrentUser :: UserRequest User + -- | Returns a 'User' for a given user ID + GetUser :: UserId -> UserRequest User + -- | Modify user's username & avatar pic + ModifyCurrentUser :: T.Text -> Base64Image User -> UserRequest User + -- | Returns a list of user 'Guild' objects the current user is a member of. + -- Requires the guilds OAuth2 scope. + GetCurrentUserGuilds :: UserRequest [PartialGuild] + -- | Leave a guild. + LeaveGuild :: GuildId -> UserRequest () + -- | Returns a list of DM 'Channel' objects + GetUserDMs :: UserRequest [Channel] + -- | Create a new DM channel with a user. Returns a DM 'Channel' object. + CreateDM :: UserId -> UserRequest Channel + + GetUserConnections :: UserRequest [ConnectionObject] + +-- | @parseAvatarImage bs@ will attempt to convert the given image bytestring +-- @bs@ to the base64 format expected by the Discord API. It may return Left +-- with an error reason if the image format could not be predetermined from the +-- opening magic bytes. This function does /not/ validate the rest of the image, +-- and this is up to the library user to check themselves. +-- +-- This function accepts all file types accepted by 'getMimeType'. +parseAvatarImage :: B.ByteString -> Either T.Text (Base64Image User) +parseAvatarImage bs + | Just mime <- getMimeType bs = Right (Base64Image mime (TE.decodeUtf8 (B64.encode bs))) + | otherwise = Left "Unsupported image format provided" + +userMajorRoute :: UserRequest a -> String +userMajorRoute c = case c of + (GetCurrentUser) -> "me " + (GetUser _) -> "user " + (ModifyCurrentUser _ _) -> "modify_user " + (GetCurrentUserGuilds) -> "get_user_guilds " + (LeaveGuild g) -> "leave_guild " <> show g + (GetUserDMs) -> "get_dms " + (CreateDM _) -> "make_dm " + (GetUserConnections) -> "connections " + +users :: R.Url 'R.Https +users = baseUrl /: "users" + +userJsonRequest :: UserRequest r -> JsonRequest +userJsonRequest c = case c of + (GetCurrentUser) -> Get (users /: "@me") mempty + + (GetUser user) -> Get (users /~ user ) mempty + + (ModifyCurrentUser name b64im) -> + Patch (users /: "@me") (pure (R.ReqBodyJson (object [ "username" .= name + , "avatar" .= b64im ]))) mempty + + (GetCurrentUserGuilds) -> Get (users /: "@me" /: "guilds") mempty + + (LeaveGuild guild) -> Delete (users /: "@me" /: "guilds" /~ guild) mempty + + (GetUserDMs) -> Get (users /: "@me" /: "channels") mempty + + (CreateDM user) -> + let body = R.ReqBodyJson $ object ["recipient_id" .= user] + in Post (users /: "@me" /: "channels") (pure body) mempty + + (GetUserConnections) -> + Get (users /: "@me" /: "connections") mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Voice.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Voice.hs new file mode 100644 index 0000000..9966aea --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Voice.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Voice API interactions +module Discord.Internal.Rest.Voice + ( VoiceRequest(..) + ) where + + +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (VoiceRequest a) where + majorRoute = voiceMajorRoute + jsonRequest = voiceJsonRequest + +-- | Data constructor for requests +data VoiceRequest a where + -- | List all available 'VoiceRegion's. + ListVoiceRegions :: VoiceRequest [VoiceRegion] + +voiceMajorRoute :: VoiceRequest a -> String +voiceMajorRoute c = case c of + (ListVoiceRegions) -> "whatever " + +voices :: R.Url 'R.Https +voices = baseUrl /: "voice" + +voiceJsonRequest :: VoiceRequest r -> JsonRequest +voiceJsonRequest c = case c of + (ListVoiceRegions) -> Get (voices /: "regions") mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs new file mode 100644 index 0000000..7b4a545 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Rest/Webhook.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Webhook API interactions +module Discord.Internal.Rest.Webhook + ( CreateWebhookOpts(..) + , ExecuteWebhookWithTokenOpts(..) + , ModifyWebhookOpts(..) + , WebhookContent(..) + , WebhookRequest(..) + ) where + +import Data.Aeson +import qualified Data.Text as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Req ((/:), (/~)) +import qualified Network.HTTP.Req as R +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import Network.HTTP.Client.MultipartFormData (partBS, partFileRequestBody) + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (WebhookRequest a) where + majorRoute = webhookMajorRoute + jsonRequest = webhookJsonRequest + +-- | Data constructors for webhook requests. +data WebhookRequest a where + -- | Creates a new webhook and returns a webhook object on success. Requires the @MANAGE_WEBHOOKS@ permission. + -- An error will be returned if a webhook name (name) is not valid. A webhook name is valid if: + -- + -- * It does not contain the substring @clyde@ (case-insensitive) + -- * It follows the nickname guidelines in the Usernames and Nicknames documentation, + -- with an exception that webhook names can be up to 80 characters + CreateWebhook :: ChannelId + -> CreateWebhookOpts + -> WebhookRequest Webhook + -- | Returns a channel's `Webhook`s as a list. Requires the @MANAGE_WEBHOOKS@ permission. + GetChannelWebhooks :: ChannelId + -> WebhookRequest [Webhook] + -- | Returns a guild's `Webhook`s as a list. Requires the @MANAGE_WEBHOOKS@ permission. + GetGuildWebhooks :: GuildId + -> WebhookRequest [Webhook] + -- | Returns the `Webhook` for the given id. If a token is given, authentication is not required. + GetWebhook :: WebhookId + -> Maybe WebhookToken + -> WebhookRequest Webhook + -- | Modify a webhook. Requires the @MANAGE_WEBHOOKS@ permission. Returns the updated `Webhook` on success. + -- If a token is given, authentication is not required. + ModifyWebhook :: WebhookId + -> Maybe WebhookToken + -> ModifyWebhookOpts + -> WebhookRequest Webhook + -- | Delete a webhook permanently. Requires the @MANAGE_WEBHOOKS@ permission. + -- If a token is given, authentication is not required. + DeleteWebhook :: WebhookId + -> Maybe WebhookToken + -> WebhookRequest () + -- | Executes a Webhook. + -- + -- Refer to [Uploading Files](https://discord.com/developers/docs/reference#uploading-files) + -- for details on attachments and @multipart/form-data@ requests. + ExecuteWebhook :: WebhookId + -> WebhookToken + -> ExecuteWebhookWithTokenOpts + -> WebhookRequest () + -- We don't support slack and github compatible webhooks because you should + -- just use execute webhook. + + -- | Returns a previously-sent webhook message from the same token. + GetWebhookMessage :: WebhookId + -> WebhookToken + -> MessageId + -> WebhookRequest Message + -- | Edits a previously-sent webhook message from the same token. + EditWebhookMessage :: WebhookId + -> WebhookToken + -> MessageId + -> T.Text -- currently we don't support the full range of edits - feel free to PR and fix this + -> WebhookRequest Message + -- | Deletes a previously-sent webhook message from the same token. + DeleteWebhookMessage :: WebhookId + -> WebhookToken + -> MessageId + -> WebhookRequest () + +-- | Options for `ModifyWebhook` and `ModifyWebhookWithToken` +data ModifyWebhookOpts = ModifyWebhookOpts + { modifyWebhookOptsName :: Maybe T.Text + , modifyWebhookOptsAvatar :: Maybe T.Text + , modifyWebhookOptsChannelId :: Maybe ChannelId + } deriving (Show, Read, Eq, Ord) + +instance ToJSON ModifyWebhookOpts where + toJSON ModifyWebhookOpts{..} = objectFromMaybes + ["channel_id" .=? modifyWebhookOptsChannelId, + "name" .=? modifyWebhookOptsName, + "avatar" .=? modifyWebhookOptsAvatar ] + +-- | Options for `CreateWebhook` +data CreateWebhookOpts = CreateWebhookOpts + { createWebhookOptsName :: T.Text + , createWebhookOptsAvatar :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateWebhookOpts where + toJSON CreateWebhookOpts{..} = objectFromMaybes + ["name" .== createWebhookOptsName, + "avatar" .=? createWebhookOptsAvatar ] + +-- | Options for `ExecuteWebhookWithToken` +data ExecuteWebhookWithTokenOpts = ExecuteWebhookWithTokenOpts + { executeWebhookWithTokenOptsUsername :: Maybe T.Text + , executeWebhookWithTokenOptsContent :: WebhookContent + } deriving (Show, Read, Eq, Ord) + +-- | A webhook's content +data WebhookContent = WebhookContentText T.Text + | WebhookContentFile T.Text B.ByteString + | WebhookContentEmbeds [CreateEmbed] + deriving (Show, Read, Eq, Ord) + +webhookContentJson :: WebhookContent -> [(AesonKey, Value)] +webhookContentJson c = case c of + WebhookContentText t -> [("content", toJSON t)] + WebhookContentFile _ _ -> [] + WebhookContentEmbeds e -> [("embeds", toJSON (createEmbed <$> e))] + +instance ToJSON ExecuteWebhookWithTokenOpts where + toJSON ExecuteWebhookWithTokenOpts{..} = objectFromMaybes $ + ["username" .=? executeWebhookWithTokenOptsUsername] + <> fmap Just (webhookContentJson executeWebhookWithTokenOptsContent) + +-- | Major routes for webhook requests +webhookMajorRoute :: WebhookRequest a -> String +webhookMajorRoute ch = case ch of + (CreateWebhook c _) -> "aaaaaahook " <> show c + (GetChannelWebhooks c) -> "aaaaaahook " <> show c + (GetGuildWebhooks g) -> "aaaaaahook " <> show g + (GetWebhook w _) -> "getwebhook " <> show w + (ModifyWebhook w _ _) -> "modifyhook " <> show w + (DeleteWebhook w _) -> "deletehook " <> show w + (ExecuteWebhook w _ _) -> "executehk " <> show w + (GetWebhookMessage w _ _) -> "gethkmsg " <> show w + (EditWebhookMessage w _ _ _) -> "edithkmsg " <> show w + (DeleteWebhookMessage w _ _) -> "delhkmsg " <> show w + +-- | Create a 'JsonRequest' from a `WebhookRequest` +webhookJsonRequest :: WebhookRequest r -> JsonRequest +webhookJsonRequest ch = case ch of + (CreateWebhook channel patch) -> + let body = pure (R.ReqBodyJson patch) + in Post (baseUrl /: "channels" /~ channel /: "webhooks") body mempty + + (GetChannelWebhooks c) -> + Get (baseUrl /: "channels" /~ c /: "webhooks") mempty + + (GetGuildWebhooks g) -> + Get (baseUrl /: "guilds" /~ g /: "webhooks") mempty + + (GetWebhook w t) -> + Get (baseUrl /: "webhooks" /~ w /? t) mempty + + (ModifyWebhook w t p) -> + Patch (baseUrl /: "webhooks" /~ w /? t) (pure (R.ReqBodyJson p)) mempty + + (DeleteWebhook w t) -> + Delete (baseUrl /: "webhooks" /~ w /? t) mempty + + (ExecuteWebhook w tok o) -> + case executeWebhookWithTokenOptsContent o of + WebhookContentFile name text -> + let part = partFileRequestBody "file" (T.unpack name) (RequestBodyBS text) + body = R.reqBodyMultipart [part] + in Post (baseUrl /: "webhooks" /~ w /~ tok) body mempty + WebhookContentText _ -> + let body = pure (R.ReqBodyJson o) + in Post (baseUrl /: "webhooks" /~ w /~ tok) body mempty + WebhookContentEmbeds embeds -> + let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed{..} = [(n,c) | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png", createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png", createEmbedImage) + , ("footer.png", createEmbedFooterIcon) ]] + parts = map mkPart (concatMap uploads embeds) + partsJson = [partBS "payload_json" $ BL.toStrict $ encode $ toJSON $ object ["embed" .= createEmbed e] | e <- embeds] + body = R.reqBodyMultipart (partsJson ++ parts) + in Post (baseUrl /: "webhooks" /~ w /: unToken tok) body mempty + + (GetWebhookMessage w t m) -> + Get (baseUrl /: "webhooks" /~ w /~ t /: "messages" /~ m) mempty + + (EditWebhookMessage w t m p) -> + Patch (baseUrl /: "webhooks" /~ w /~ t /: "messages" /~ m) (pure (R.ReqBodyJson $ object ["content" .= p])) mempty + + (DeleteWebhookMessage w t m) -> + Delete (baseUrl /: "webhooks" /~ w /~ t /: "messages" /~ m) mempty diff --git a/deps/discord-haskell/src/Discord/Internal/Types.hs b/deps/discord-haskell/src/Discord/Internal/Types.hs new file mode 100644 index 0000000..0dac11c --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types.hs @@ -0,0 +1,74 @@ +-- | Re-export ALL the internal type modules. Hiding is in Discord.Types +module Discord.Internal.Types + ( module Discord.Internal.Types.Prelude, + module Discord.Internal.Types.Channel, + module Discord.Internal.Types.Color, + module Discord.Internal.Types.Events, + module Discord.Internal.Types.Gateway, + module Discord.Internal.Types.Guild, + module Discord.Internal.Types.User, + module Discord.Internal.Types.Embed, + module Discord.Internal.Types.Components, + module Discord.Internal.Types.Emoji, + module Discord.Internal.Types.RolePermissions, + module Data.Aeson, + module Data.Time.Clock, + userFacingEvent, + ) +where + +import Data.Aeson (Object, ToJSON (toJSON)) +import Data.Time.Clock (UTCTime (..)) +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Color +import Discord.Internal.Types.Components +import Discord.Internal.Types.Embed +import Discord.Internal.Types.Emoji +import Discord.Internal.Types.Events +import Discord.Internal.Types.Gateway +import Discord.Internal.Types.Guild +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User +import Discord.Internal.Types.RolePermissions + +-- | Converts an internal event to its user facing counterpart +userFacingEvent :: EventInternalParse -> Event +userFacingEvent event = case event of + InternalReady a b c d e f g -> Ready a b c d e f g + InternalResumed a -> Resumed a + InternalChannelCreate a -> ChannelCreate a + InternalChannelUpdate a -> ChannelUpdate a + InternalChannelDelete a -> ChannelDelete a + InternalThreadCreate a -> ThreadCreate a + InternalThreadUpdate a -> ThreadUpdate a + InternalThreadDelete a -> ThreadDelete a + InternalThreadListSync a -> ThreadListSync a + InternalThreadMembersUpdate a -> ThreadMembersUpdate a + InternalChannelPinsUpdate a b -> ChannelPinsUpdate a b + InternalGuildCreate a b -> GuildCreate a b + InternalGuildUpdate a -> GuildUpdate a + InternalGuildDelete a -> GuildDelete a + InternalGuildBanAdd a b -> GuildBanAdd a b + InternalGuildBanRemove a b -> GuildBanRemove a b + InternalGuildEmojiUpdate a b -> GuildEmojiUpdate a b + InternalGuildIntegrationsUpdate a -> GuildIntegrationsUpdate a + InternalGuildMemberAdd a b -> GuildMemberAdd a b + InternalGuildMemberRemove a b -> GuildMemberRemove a b + InternalGuildMemberUpdate a b c d -> GuildMemberUpdate a b c d + InternalGuildMemberChunk a b -> GuildMemberChunk a b + InternalGuildRoleCreate a b -> GuildRoleCreate a b + InternalGuildRoleUpdate a b -> GuildRoleUpdate a b + InternalGuildRoleDelete a b -> GuildRoleDelete a b + InternalMessageCreate a -> MessageCreate a + InternalMessageUpdate a b -> MessageUpdate a b + InternalMessageDelete a b -> MessageDelete a b + InternalMessageDeleteBulk a b -> MessageDeleteBulk a b + InternalMessageReactionAdd a -> MessageReactionAdd a + InternalMessageReactionRemove a -> MessageReactionRemove a + InternalMessageReactionRemoveAll a b -> MessageReactionRemoveAll a b + InternalMessageReactionRemoveEmoji a -> MessageReactionRemoveEmoji a + InternalPresenceUpdate a -> PresenceUpdate a + InternalTypingStart a -> TypingStart a + InternalUserUpdate a -> UserUpdate a + InternalInteractionCreate a -> InteractionCreate a + InternalUnknownEvent a b -> UnknownEvent a b diff --git a/deps/discord-haskell/src/Discord/Internal/Types/ApplicationCommands.hs b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationCommands.hs new file mode 100644 index 0000000..d05a082 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/ApplicationCommands.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.ApplicationCommands + ( ApplicationCommand (..), + Options (..), + OptionSubcommandOrGroup (..), + OptionSubcommand (..), + OptionValue (..), + createChatInput, + createUser, + createMessage, + CreateApplicationCommand (..), + EditApplicationCommand (..), + defaultEditApplicationCommand, + Choice (..), + ChannelTypeOption (..), + GuildApplicationCommandPermissions (..), + ApplicationCommandPermissions (..), + Number, + AutocompleteOrChoice, + LocalizedText, + Locale + ) +where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Number, Object), object, withArray, withObject, (.!=), (.:), (.:!), (.:?)) +import Data.Aeson.Types (Pair, Parser) +import Data.Foldable (Foldable (toList)) +import Data.Scientific (Scientific) +import Data.Char (isLower, isNumber) +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, GuildId, Snowflake, objectFromMaybes, (.==), (.=?)) +import Data.Map.Strict (Map) +import Discord.Internal.Types.Channel ( ChannelTypeOption(..) ) + +import qualified Data.Text as T + +type Number = Scientific + +-- | The structure for an application command. +data ApplicationCommand + = ApplicationCommandUser + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. + applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. + applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. + applicationCommandName :: T.Text, + -- | The localized names of the application command. + applicationCommandLocalizedName :: Maybe LocalizedText, + -- | What permissions are required to use this command by default. + applicationCommandDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + applicationCommandDMPermission :: Maybe Bool, + -- | Autoincrementing version identifier updated during substantial record changes. + applicationCommandVersion :: Snowflake + } + | ApplicationCommandMessage + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. + applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. + applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. + applicationCommandName :: T.Text, + -- | The localized names of the application command. + applicationCommandLocalizedName :: Maybe LocalizedText, + -- | What permissions are required to use this command by default. + applicationCommandDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + applicationCommandDMPermission :: Maybe Bool, + -- | Autoincrementing version identifier updated during substantial record changes. + applicationCommandVersion :: Snowflake + } + | ApplicationCommandChatInput + { -- | The id of the application command. + applicationCommandId :: ApplicationCommandId, + -- | The id of the application the command comes from. + applicationCommandApplicationId :: ApplicationId, + -- | The guild the application command is registered in. + applicationCommandGuildId :: Maybe GuildId, + -- | The name of the application command. + applicationCommandName :: T.Text, + -- | The localized names of the application command. + applicationCommandLocalizedName :: Maybe LocalizedText, + -- | The description of the application command. + applicationCommandDescription :: T.Text, + -- | The localized descriptions of the application command. + applicationCommandLocalizedDescription :: Maybe LocalizedText, + -- | The parameters for the command. + applicationCommandOptions :: Maybe Options, + -- | What permissions are required to use this command by default. + applicationCommandDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + applicationCommandDMPermission :: Maybe Bool, + -- | Autoincrementing version identifier updated during substantial record changes. + applicationCommandVersion :: Snowflake + } + deriving (Show, Eq, Read) + +instance FromJSON ApplicationCommand where + parseJSON = + withObject + "ApplicationCommand" + ( \v -> do + acid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + name <- v .: "name" + lname <- v .:? "name_localizations" + defPerm <- v .:? "default_member_permissions" + dmPerm <- v .:? "dm_permission" + version <- v .: "version" + t <- v .:? "type" :: Parser (Maybe Int) + case t of + (Just 2) -> return $ ApplicationCommandUser acid aid gid name lname defPerm dmPerm version + (Just 3) -> return $ ApplicationCommandMessage acid aid gid name lname defPerm dmPerm version + _ -> do + desc <- v .: "description" + options <- v .:? "options" + ldesc <- v .:? "description_localizations" + return $ ApplicationCommandChatInput acid aid gid name lname desc ldesc options defPerm dmPerm version + ) + +-- | Either subcommands and groups, or values. +data Options + = OptionsSubcommands [OptionSubcommandOrGroup] + | OptionsValues [OptionValue] + deriving (Show, Eq, Read) + +instance FromJSON Options where + parseJSON = + withArray + "Options" + ( \a -> do + let a' = toList a + case a' of + [] -> return $ OptionsValues [] + (v' : _) -> + withObject + "Options item" + ( \v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then OptionsSubcommands <$> mapM parseJSON a' + else OptionsValues <$> mapM parseJSON a' + ) + v' + ) + +instance ToJSON Options where + toJSON (OptionsSubcommands o) = toJSON o + toJSON (OptionsValues o) = toJSON o + +-- | Either a subcommand group or a subcommand. +data OptionSubcommandOrGroup + = OptionSubcommandGroup + { -- | The name of the subcommand group + optionSubcommandGroupName :: T.Text, + -- | The localized name of the subcommand group + optionSubcommandGroupLocalizedName :: Maybe LocalizedText, + -- | The description of the subcommand group + optionSubcommandGroupDescription :: T.Text, + -- | The localized description of the subcommand group + optionSubcommandGroupLocalizedDescription :: Maybe LocalizedText, + -- | The subcommands in this subcommand group + optionSubcommandGroupOptions :: [OptionSubcommand] + } + | OptionSubcommandOrGroupSubcommand OptionSubcommand + deriving (Show, Eq, Read) + +instance FromJSON OptionSubcommandOrGroup where + parseJSON = + withObject + "OptionSubcommandOrGroup" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + OptionSubcommandGroup + <$> v .: "name" + <*> v .:? "name_localizations" + <*> v .: "description" + <*> v .:? "description_localizations" + <*> v .: "options" + 1 -> OptionSubcommandOrGroupSubcommand <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) + +instance ToJSON OptionSubcommandOrGroup where + toJSON OptionSubcommandGroup {..} = + object + [ ("type", Number 2), + ("name", toJSON optionSubcommandGroupName), + ("name_localizations", toJSON optionSubcommandGroupLocalizedName), + ("description", toJSON optionSubcommandGroupDescription), + ("description_localizations", toJSON optionSubcommandGroupLocalizedDescription), + ("options", toJSON optionSubcommandGroupOptions) + ] + toJSON (OptionSubcommandOrGroupSubcommand a) = toJSON a + +-- | Data for a single subcommand. +data OptionSubcommand = OptionSubcommand + { -- | The name of the subcommand + optionSubcommandName :: T.Text, + -- | The localized name of the subcommand + optionSubcommandLocalizedName :: Maybe LocalizedText, + -- | The description of the subcommand + optionSubcommandDescription :: T.Text, + -- | The localized description of the subcommand + optionSubcommandLocalizedDescription :: Maybe LocalizedText, + -- | What options are there in this subcommand + optionSubcommandOptions :: [OptionValue] + } + deriving (Show, Eq, Read) + +instance FromJSON OptionSubcommand where + parseJSON = + withObject + "OptionSubcommand" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + OptionSubcommand + <$> v .: "name" + <*> v .:? "name_localizations" + <*> v .: "description" + <*> v .:? "description_localizations" + <*> v .:? "options" .!= [] + _ -> fail "unexpected subcommand type" + ) + +instance ToJSON OptionSubcommand where + toJSON OptionSubcommand {..} = + object + [ ("type", Number 1), + ("name", toJSON optionSubcommandName), + ("name_localizations", toJSON optionSubcommandLocalizedName), + ("description", toJSON optionSubcommandDescription), + ("description_localizations", toJSON optionSubcommandLocalizedDescription), + ("options", toJSON optionSubcommandOptions) + ] + +-- | Data for a single value. +data OptionValue + = OptionValueString + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + optionValueStringChoices :: AutocompleteOrChoice T.Text, + -- | The minimum length of the string (minimum 0) + optionValueStringMinLen :: Maybe Integer, + -- | The maximum length of the string (minimum 1) + optionValueStringMaxLen :: Maybe Integer + } + | OptionValueInteger + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + optionValueIntegerChoices :: AutocompleteOrChoice Integer, + -- | The lower bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueIntegerMinVal :: Maybe Integer, + -- | The upper bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueIntegerMaxVal :: Maybe Integer + } + | OptionValueBoolean + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueUser + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueChannel + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | What type of channel can be put in here + optionValueChannelTypes :: Maybe [ChannelTypeOption] + } + | OptionValueRole + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueMentionable + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool + } + | OptionValueNumber + { -- | The name of the value + optionValueName :: T.Text, + -- | The localized name of the value + optionValueLocalizedName :: Maybe LocalizedText, + -- | The description of the value + optionValueDescription :: T.Text, + -- | The localized description of the value + optionValueLocalizedDescription :: Maybe LocalizedText, + -- | Whether this option is required + optionValueRequired :: Bool, + -- | Whether to autocomplete or have a list of named choices. For neither option, use `Left False` + optionValueNumberChoices :: AutocompleteOrChoice Number, + -- | The lower bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueNumberMinVal :: Maybe Number, + -- | The upper bound of values permitted. If choices are provided or autocomplete is on, this can be ignored + optionValueNumberMaxVal :: Maybe Number + } + deriving (Show, Eq, Read) + +instance FromJSON OptionValue where + parseJSON = + withObject + "OptionValue" + ( \v -> do + name <- v .: "name" + lname <- v .:? "name_localizations" + desc <- v .: "description" + ldesc <- v .:? "description_localizations" + required <- v .:? "required" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + OptionValueString name lname desc ldesc required + <$> parseJSON (Object v) + <*> v .:? "min_length" + <*> v .:? "max_length" + 4 -> + OptionValueInteger name lname desc ldesc required + <$> parseJSON (Object v) + <*> v .:? "min_value" + <*> v .:? "max_value" + 10 -> + OptionValueNumber name lname desc ldesc required + <$> parseJSON (Object v) + <*> v .:? "min_value" + <*> v .:? "max_value" + 7 -> + OptionValueChannel name lname desc ldesc required + <$> v .:? "channel_types" + 5 -> return $ OptionValueBoolean name lname desc ldesc required + 6 -> return $ OptionValueUser name lname desc ldesc required + 8 -> return $ OptionValueRole name lname desc ldesc required + 9 -> return $ OptionValueMentionable name lname desc ldesc required + _ -> fail "unknown application command option value type" + ) + +instance ToJSON OptionValue where + toJSON OptionValueString {..} = + object + [ ("type", Number 3), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("min_length", toJSON optionValueStringMinLen), + ("max_length", toJSON optionValueStringMaxLen), + choiceOrAutocompleteToJSON optionValueStringChoices + ] + toJSON OptionValueInteger {..} = + object + [ ("type", Number 4), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("min_value", toJSON optionValueIntegerMinVal), + ("max_value", toJSON optionValueIntegerMaxVal), + choiceOrAutocompleteToJSON optionValueIntegerChoices + ] + toJSON OptionValueNumber {..} = + object + [ ("type", Number 10), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("min_value", toJSON optionValueNumberMinVal), + ("max_value", toJSON optionValueNumberMaxVal), + choiceOrAutocompleteToJSON optionValueNumberChoices + ] + toJSON OptionValueChannel {..} = + object + [ ("type", Number 7), + ("name", toJSON optionValueName), + ("description", toJSON optionValueDescription), + ("name_localizations", toJSON optionValueLocalizedName), + ("description_localizations", toJSON optionValueLocalizedDescription), + ("required", toJSON optionValueRequired), + ("channel_types", toJSON optionValueChannelTypes) + ] + toJSON acov = + object + [ ("type", Number (t acov)), + ("name", toJSON $ optionValueName acov), + ("description", toJSON $ optionValueDescription acov), + ("name_localizations", toJSON $ optionValueLocalizedName acov), + ("description_localizations", toJSON $ optionValueLocalizedDescription acov), + ("required", toJSON $ optionValueRequired acov) + ] + where + t OptionValueBoolean {} = 5 + t OptionValueUser {} = 6 + t OptionValueRole {} = 8 + t OptionValueMentionable {} = 9 + t _ = -1 + +-- | Data type to be used when creating application commands. The specification +-- is below. +-- +-- If a command of the same type and and name is sent to the server, it will +-- overwrite any command that already exists in the same scope (guild vs +-- global). +-- +-- The description has to be empty for non-slash command application +-- commands, as do the options. The options need to be `Nothing` for non-slash +-- commands, too. If one of the options is a subcommand or subcommand group, +-- the base command will no longer be usable. +-- +-- A subcommand group can have subcommands within it. This is the maximum amount +-- of command nesting permitted. +-- +-- https://discord.com/developers/docs/interactions/application-commands#create-global-application-command +data CreateApplicationCommand + = CreateApplicationCommandChatInput + { -- | The application command name (1-32 chars). + createName :: T.Text, + -- | The localized application name + createLocalizedName :: Maybe LocalizedText, + -- | The application command description (1-100 chars). + createDescription :: T.Text, + -- | The localized application command description. + createLocalizedDescription :: Maybe LocalizedText, + -- | What options the application (max length 25). + createOptions :: Maybe Options, + -- | The default permissions required for members set when using the command + -- in a guild. + -- Set of permissions represented as a bit set. + createDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + createDMPermission :: Maybe Bool + } + | CreateApplicationCommandUser + { -- | The application command name (1-32 chars). + createName :: T.Text, + -- | The localized application name + createLocalizedName :: Maybe LocalizedText, + -- | The default permissions required for members set when using the command + -- in a guild. + -- Set of permissions represented as a bit set. + createDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + createDMPermission :: Maybe Bool + } + | CreateApplicationCommandMessage + { -- | The application command name (1-32 chars). + createName :: T.Text, + -- | The localized application name + createLocalizedName :: Maybe LocalizedText, + -- | The default permissions required for members set when using the command + -- in a guild. + -- Set of permissions represented as a bit set. + createDefaultMemberPermissions :: Maybe T.Text, + -- | Whether the command is available in DMs. + createDMPermission :: Maybe Bool + } + deriving (Show, Eq, Read) + +instance ToJSON CreateApplicationCommand where + toJSON CreateApplicationCommandChatInput {..} = + objectFromMaybes + [ "name" .== createName, + "name_localizations" .=? createLocalizedName, + "description" .== createDescription, + "description_localizations" .=? createLocalizedDescription, + "options" .=? createOptions, + "default_member_permissions" .== createDefaultMemberPermissions, + "dm_permission" .== createDMPermission, + "type" .== Number 1 + ] + toJSON CreateApplicationCommandUser {..} = + objectFromMaybes + [ "name" .== createName, + "name_localizations" .=? createLocalizedName, + "default_member_permissions" .== createDefaultMemberPermissions, + "dm_permission" .== createDMPermission, + "type" .== Number 2 + ] + toJSON CreateApplicationCommandMessage {..} = + objectFromMaybes + [ "name" .== createName, + "name_localizations" .=? createLocalizedName, + "default_member_permissions" .== createDefaultMemberPermissions, + "dm_permission" .== createDMPermission, + "type" .== Number 3 + ] + +nameIsValid :: Bool -> T.Text -> Bool +nameIsValid isChatInput name = l >= 1 && l <= 32 && isChatInput <= T.all validChar name + where + l = T.length name + validChar c = c == '-' || c == '_' || isLower c || isNumber c + +-- | Create the basics for a chat input (slash command). Use record overwriting +-- to enter the other values. The name needs to be all lower case letters, and +-- between 1 and 32 characters. The description has to be non-empty and less +-- than or equal to 100 characters. +createChatInput :: T.Text -> T.Text -> Maybe CreateApplicationCommand +createChatInput name desc + | nameIsValid True name && not (T.null desc) && T.length desc <= 100 = Just $ CreateApplicationCommandChatInput name Nothing desc Nothing Nothing Nothing Nothing + | otherwise = Nothing + +-- | Create the basics for a user command. Use record overwriting to enter the +-- other values. The name needs to be between 1 and 32 characters. +createUser :: T.Text -> Maybe CreateApplicationCommand +createUser name + | nameIsValid False name = Just $ CreateApplicationCommandUser name Nothing Nothing Nothing + | otherwise = Nothing + +-- | Create the basics for a message command. Use record overwriting to enter +-- the other values. The name needs to be between 1 and 32 characters. +createMessage :: T.Text -> Maybe CreateApplicationCommand +createMessage name + | nameIsValid False name = Just $ CreateApplicationCommandMessage name Nothing Nothing Nothing + | otherwise = Nothing + +-- | Data type to be used when editing application commands. The specification +-- is below. See `CreateApplicationCommand` for an explanation for the +-- parameters. +-- +-- https://discord.com/developers/docs/interactions/application-commands#edit-global-application-command +data EditApplicationCommand + = EditApplicationCommandChatInput + { editName :: Maybe T.Text, + editLocalizedName :: Maybe LocalizedText, + editDescription :: Maybe T.Text, + editLocalizedDescription :: Maybe LocalizedText, + editOptions :: Maybe Options, + editDefaultMemberPermissions :: Maybe T.Text, + editDMPermission :: Maybe Bool + } + | EditApplicationCommandUser + { editName :: Maybe T.Text, + editLocalizedName :: Maybe LocalizedText, + editDefaultMemberPermissions :: Maybe T.Text, + editDMPermission :: Maybe Bool + } + | EditApplicationCommandMessage + { editName :: Maybe T.Text, + editLocalizedName :: Maybe LocalizedText, + editDefaultMemberPermissions :: Maybe T.Text, + editDMPermission :: Maybe Bool + } + +defaultEditApplicationCommand :: Int -> EditApplicationCommand +defaultEditApplicationCommand 2 = EditApplicationCommandUser Nothing Nothing Nothing Nothing +defaultEditApplicationCommand 3 = EditApplicationCommandMessage Nothing Nothing Nothing Nothing +defaultEditApplicationCommand _ = EditApplicationCommandChatInput Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON EditApplicationCommand where + toJSON EditApplicationCommandChatInput {..} = + objectFromMaybes + [ "name" .=? editName, + "name_localization" .=? editLocalizedName, + "description" .=? editDescription, + "description_localization" .=? editLocalizedDescription, + "options" .=? editOptions, + "default_member_permissions" .=? editDefaultMemberPermissions, + "dm_permission" .=? editDMPermission, + "type" .== Number 1 + ] + toJSON EditApplicationCommandUser {..} = + objectFromMaybes + [ "name" .=? editName, + "name_localization" .=? editLocalizedName, + "default_member_permissions" .=? editDefaultMemberPermissions, + "dm_permission" .=? editDMPermission, + "type" .== Number 2 + ] + toJSON EditApplicationCommandMessage {..} = + objectFromMaybes + [ "name" .=? editName, + "name_localization" .=? editLocalizedName, + "default_member_permissions" .=? editDefaultMemberPermissions, + "dm_permission" .=? editDMPermission, + "type" .== Number 3 + ] + +data Choice a = Choice + { -- | The name of the choice + choiceName :: T.Text, + -- | The localized name of the choice + choiceLocalizedName :: Maybe LocalizedText, + -- | The value of the choice + choiceValue :: a + } + deriving (Show, Read, Eq, Ord) + +instance Functor Choice where + fmap f (Choice s l a) = Choice s l (f a) + +instance (ToJSON a) => ToJSON (Choice a) where + toJSON Choice {..} = + object + [ ("name", toJSON choiceName), + ("value", toJSON choiceValue), + ("name_localizations", toJSON choiceLocalizedName) + ] + +instance (FromJSON a) => FromJSON (Choice a) where + parseJSON = + withObject + "Choice" + ( \v -> + Choice + <$> v .: "name" + <*> v .:? "name_localizations" + <*> v .: "value" + ) + +type AutocompleteOrChoice a = Either Bool [Choice a] + +instance {-# OVERLAPPING #-} (FromJSON a) => FromJSON (AutocompleteOrChoice a) where + parseJSON = + withObject + "AutocompleteOrChoice" + ( \v -> do + mcs <- v .:! "choices" + case mcs of + Nothing -> Left <$> v .:? "autocomplete" .!= False + Just cs -> return $ Right cs + ) + +choiceOrAutocompleteToJSON :: (ToJSON a) => AutocompleteOrChoice a -> Pair +choiceOrAutocompleteToJSON (Left b) = ("autocomplete", toJSON b) +choiceOrAutocompleteToJSON (Right cs) = ("choices", toJSON cs) + +data GuildApplicationCommandPermissions = GuildApplicationCommandPermissions + { -- | The id of the command. + guildApplicationCommandPermissionsId :: ApplicationCommandId, + -- | The id of the application. + guildApplicationCommandPermissionsApplicationId :: ApplicationId, + -- | The id of the guild. + guildApplicationCommandPermissionsGuildId :: GuildId, + -- | The permissions for the command in the guild. + guildApplicationCommandPermissionsPermissions :: [ApplicationCommandPermissions] + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildApplicationCommandPermissions where + parseJSON = + withObject + "GuildApplicationCommandPermissions" + ( \v -> + GuildApplicationCommandPermissions + <$> v .: "id" + <*> v .: "application_id" + <*> v .: "guild_id" + <*> v .: "permissions" + ) + +instance ToJSON GuildApplicationCommandPermissions where + toJSON GuildApplicationCommandPermissions {..} = + objectFromMaybes + [ "id" .== guildApplicationCommandPermissionsId, + "application_id" .== guildApplicationCommandPermissionsApplicationId, + "guild_id" .== guildApplicationCommandPermissionsGuildId, + "permissions" .== guildApplicationCommandPermissionsPermissions + ] + +-- | Application command permissions allow you to enable or disable commands for +-- specific users or roles within a guild. +data ApplicationCommandPermissions = ApplicationCommandPermissions + { -- | The id of the role or user. + applicationCommandPermissionsId :: Snowflake, + -- | Choose either role (1) or user (2). + applicationCommandPermissionsType :: Integer, + -- | Whether to allow or not. + applicationCommandPermissionsPermission :: Bool + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ApplicationCommandPermissions where + parseJSON = + withObject + "ApplicationCommandPermissions" + ( \v -> + ApplicationCommandPermissions + <$> v .: "id" + <*> v .: "type" + <*> v .: "permission" + ) + +instance ToJSON ApplicationCommandPermissions where + toJSON ApplicationCommandPermissions {..} = + objectFromMaybes + [ "id" .== applicationCommandPermissionsId, + "type" .== applicationCommandPermissionsType, + "permission" .== applicationCommandPermissionsPermission + ] + +-- | A discord locale. See +-- <https://discord.com/developers/docs/reference#locales> for available locales +type Locale = T.Text + +-- | Translations for a text +type LocalizedText = Map Locale T.Text diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs new file mode 100644 index 0000000..9f4671a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Channel.hs @@ -0,0 +1,879 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Data structures pertaining to Discord Channels +module Discord.Internal.Types.Channel ( + Channel (..) + , channelIsInGuild + , Overwrite (..) + , ThreadMetadata (..) + , ThreadMember (..) + , ThreadListSyncFields (..) + , ThreadMembersUpdateFields (..) + , Message (..) + , AllowedMentions (..) + , MessageReaction (..) + , Attachment (..) + , Nonce (..) + , MessageReference (..) + , MessageType (..) + , MessageActivity (..) + , MessageActivityType (..) + , MessageFlag (..) + , MessageFlags (..) + , MessageInteraction (..) + + , ChannelTypeOption (..) + ) where + +import Control.Applicative (empty) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Default (Default, def) +import Data.Text (Text) +import Data.Time.Clock +import qualified Data.Text as T +import Data.Bits +import Data.Data (Data) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User (User(..), GuildMember) +import Discord.Internal.Types.Embed +import Discord.Internal.Types.Components (ActionRow) +import Discord.Internal.Types.Emoji + +-- | Guild channels represent an isolated set of users and messages in a Guild (Server) +data Channel + -- | A text channel in a guild. + = ChannelText + { channelId :: ChannelId -- ^ The id of the channel (Will be equal to + -- the guild if it's the "general" channel). + , channelGuild :: GuildId -- ^ The id of the guild. + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelPosition :: Integer -- ^ The storing position of the channel. + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's + , channelUserRateLimit :: Integer -- ^ Seconds before a user can speak again + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelTopic :: T.Text -- ^ The topic of the channel. (0 - 1024 chars). + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + } + -- | A news Channel in a guild. + | ChannelNews + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters) + , channelPosition :: Integer -- ^ The position of the channel + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overrite's + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelTopic :: T.Text -- ^ Topic of the channel (0 - 1024 characters) + , channelLastMessage :: Maybe MessageId -- ^ The ID of the last message of the channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel (category) + } + -- | A store page channel in a guild + | ChannelStorePage + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelName :: T.Text -- ^ The name of the channel (2 - 1000 characters) + , channelPosition :: Integer -- ^ The position of the channel + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overrite's + , channelParentId :: Maybe ParentId -- ^ The id of the parrent channel (category) + } + -- | A voice channel in a guild. + | ChannelVoice + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelName :: T.Text -- ^ The name of the channel (2 - 1000) characters + , channelPosition :: Integer -- ^ The position of the channel + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overrite's + , channelNSFW :: Bool -- ^ Is not-safe-for-work + , channelBitRate :: Integer -- ^ The bitrate (in bps) of the channel. + , channelUserLimit :: Integer -- ^ The user limit of the voice channel. + , channelParentId :: Maybe ParentId -- ^ The id of the parrent channel (category) + } + -- | DM Channels represent a one-to-one conversation between two users, outside the scope + -- of guilds + | ChannelDirectMessage + { channelId :: ChannelId -- ^ The id of the channel + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). + , channelLastMessage :: Maybe MessageId -- ^ The last message sent to the channel + } + -- | Like a 'ChannelDirectMessage' but for more people + | ChannelGroupDM + { channelId :: ChannelId -- ^ The id of the channel + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipent(s). + , channelLastMessage :: Maybe MessageId -- ^ The last message sent to the channel + } + -- | A channel category + | ChannelGuildCategory + { channelId :: ChannelId -- ^ The id of the category + , channelGuild :: GuildId -- ^ The id of the gild + , channelName :: T.Text -- ^ The name of the category + , channelPosition :: Integer -- ^ The position of the category + , channelPermissions :: [Overwrite] -- ^ A list of permission 'Overrite's + } + -- | A stage channel + | ChannelStage + { channelId :: ChannelId -- ^ The id of the channel + , channelGuild :: GuildId -- ^ The id of the guild + , channelStageId :: StageId -- ^ The id of the stage + , channelStageTopic :: Text -- ^ The topic text + } + -- | A news Thread + | ChannelNewsThread + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } + -- | A thread anyone can join + | ChannelPublicThread + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } + -- | An on-invite thread + | ChannelPrivateThread + { channelId :: ChannelId -- ^ The id of the thread + , channelGuild :: GuildId -- ^ The id of the guild. + , channelThreadName :: Maybe T.Text -- ^ The name of the channel (2 - 1000 characters). + , channelUserRateLimitThread :: Maybe Integer -- ^ Seconds before a user can speak again + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + , channelParentId :: Maybe ParentId -- ^ The id of the parent channel + , channelThreadMetadata :: Maybe ThreadMetadata -- ^ Metadata about this thread + , channelThreadMember :: Maybe ThreadMember -- ^ Used to indicate if the user has joined the thread + } + -- | A channel of unknown type + | ChannelUnknownType + { channelId :: ChannelId -- ^ The id of the channel + , channelJSON :: Text -- ^ The library couldn't parse the channel type, here is the raw JSON + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Channel where + parseJSON = withObject "Channel" $ \o -> do + type' <- (o .: "type") :: Parser Int + case type' of + 0 -> + ChannelText <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .: "rate_limit_per_user" + <*> o .:? "nsfw" .!= False + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + 1 -> + ChannelDirectMessage <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 2 -> + ChannelVoice <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "nsfw" .!= False + <*> o .: "bitrate" + <*> o .: "user_limit" + <*> o .:? "parent_id" + 3 -> + ChannelGroupDM <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 4 -> + ChannelGuildCategory <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + 5 -> + ChannelNews <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .: "permission_overwrites" + <*> o .:? "nsfw" .!= False + <*> o .:? "topic" .!= "" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + 6 -> + ChannelStorePage <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "name" + <*> o .: "position" + <*> o .:? "nsfw" .!= False + <*> o .: "permission_overwrites" + <*> o .:? "parent_id" + 10 -> ChannelNewsThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 11 -> ChannelPublicThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 12 -> ChannelPrivateThread <$> o.: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .:? "name" + <*> o .:? "rate_limit_per_user" + <*> o .:? "last_message_id" + <*> o .:? "parent_id" + <*> o .:? "thread_metadata" + <*> o .:? "member" + 13 -> + ChannelStage <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + <*> o .: "id" + <*> o .:? "topic" .!= "" + _ -> ChannelUnknownType <$> o .: "id" + <*> pure (T.pack (show o)) + +instance ToJSON Channel where + toJSON ChannelText{..} = objectFromMaybes + [ "type" .== Number 0 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "position" .== channelPosition + , "rate_limit_per_user" .== channelUserRateLimit + , "nsfw" .== channelNSFW + , "permission_overwrites" .== channelPermissions + , "topic" .== channelTopic + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + ] + toJSON ChannelNews{..} = objectFromMaybes + [ "type" .== Number 5 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "position" .== channelPosition + , "permission_overwrites" .== channelPermissions + , "nsfw" .== channelNSFW + , "topic" .== channelTopic + , "last_message_id" .=? channelLastMessage + , "parent_id" .=? channelParentId + ] + toJSON ChannelStorePage{..} = objectFromMaybes + [ "type" .== Number 6 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "nsfw" .== channelNSFW + , "position" .== channelPosition + , "permission_overwrites" .== channelPermissions + ] + toJSON ChannelDirectMessage{..} = objectFromMaybes + [ "type" .== Number 1 + , "id" .== channelId + , "recipients" .== channelRecipients + , "last_message_id" .=? channelLastMessage + ] + toJSON ChannelVoice{..} = objectFromMaybes + [ "type" .== Number 2 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .== channelName + , "position" .== channelPosition + , "nsfw" .== channelNSFW + , "permission_overwrites" .== channelPermissions + , "bitrate" .== channelBitRate + , "user_limit" .== channelUserLimit + ] + toJSON ChannelGroupDM{..} = objectFromMaybes + [ "type" .== Number 3 + , "id" .== channelId + , "recipients" .== channelRecipients + , "last_message_id" .=? channelLastMessage + ] + toJSON ChannelGuildCategory{..} = objectFromMaybes + [ "type" .== Number 4 + , "id" .== channelId + , "name" .== channelName + , "guild_id" .== channelGuild + ] + toJSON ChannelStage{..} = objectFromMaybes + [ "type" .== Number 13 + , "id" .== channelId + , "guild_id" .== channelGuild + , "channel_id" .== channelStageId + , "topic" .== channelStageTopic + ] + toJSON ChannelNewsThread{..} = objectFromMaybes + [ "type" .== Number 10 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .=? channelThreadName + , "rate_limit_per_user" .=? channelUserRateLimitThread + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + , "thread_metadata" .=? channelThreadMetadata + , "member" .=? channelThreadMember + ] + toJSON ChannelPublicThread{..} = objectFromMaybes + [ "type" .== Number 11 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .=? channelThreadName + , "rate_limit_per_user" .=? channelUserRateLimitThread + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + , "thread_metadata" .=? channelThreadMetadata + , "member" .=? channelThreadMember + ] + toJSON ChannelPrivateThread{..} = objectFromMaybes + [ "type" .== Number 12 + , "id" .== channelId + , "guild_id" .== channelGuild + , "name" .=? channelThreadName + , "rate_limit_per_user" .=? channelUserRateLimitThread + , "last_message_id" .=? channelLastMessage + , "parent_id" .== channelParentId + , "thread_metadata" .=? channelThreadMetadata + , "member" .=? channelThreadMember + ] + toJSON ChannelUnknownType{..} = objectFromMaybes + [ "id" .== channelId + , "json" .== channelJSON + ] + +-- | If the channel is part of a guild (has a guild id field) +channelIsInGuild :: Channel -> Bool +channelIsInGuild c = case c of + ChannelGuildCategory{} -> True + ChannelText{} -> True + ChannelVoice{} -> True + ChannelNews{} -> True + ChannelStorePage{} -> True + ChannelNewsThread{} -> True + ChannelPublicThread{} -> True + ChannelPrivateThread{} -> True + _ -> False + +-- | Permission overwrites for a channel. +data Overwrite = Overwrite + { overwriteId :: Either RoleId UserId -- ^ 'Role' or 'User' id + , overwriteAllow :: T.Text -- ^ Allowed permission bit set + , overwriteDeny :: T.Text -- ^ Denied permission bit set + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Overwrite where + parseJSON = withObject "Overwrite" $ \o -> do + t <- o .: "type" + i <- case (t :: Int) of + 0 -> Left <$> o .: "id" + 1 -> Right <$> o .: "id" + _ -> error "Type field can only be 0 (role id) or 1 (user id)" + Overwrite i + <$> o .: "allow" + <*> o .: "deny" + +instance ToJSON Overwrite where + toJSON Overwrite{..} = object + [ ("id", toJSON $ either unId unId overwriteId) + , ("type", toJSON (either (const 0) (const 1) overwriteId :: Int)) + , ("allow", toJSON overwriteAllow) + , ("deny", toJSON overwriteDeny) + ] + +-- | Metadata for threads. +data ThreadMetadata = ThreadMetadata + { threadMetadataArchived :: Bool -- ^ Is the thread archived? + , threadMetadataAutoArchive :: Integer -- ^ How long after activity should the thread auto archive + , threadMetadataArchiveTime :: UTCTime -- ^ When was the last time the archive status changed? + , threadMetadataLocked :: Bool -- ^ Is the thread locked? (only MANAGE_THREADS users can unarchive) + , threadMetadataInvitable :: Maybe Bool -- ^ Can non-mods add other non-mods? (private threads only) + , threadMetadataCreateTime :: Maybe UTCTime -- ^ When was the thread created? + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMetadata where + parseJSON = withObject "ThreadMetadata" $ \o -> + ThreadMetadata <$> o .: "archived" + <*> o .: "auto_archive_duration" + <*> o .: "archive_timestamp" + <*> o .: "locked" + <*> o .:? "invitable" + <*> o .:? "create_timestamp" + +instance ToJSON ThreadMetadata where + toJSON ThreadMetadata{..} = objectFromMaybes + [ "archived" .== threadMetadataArchived + , "auto_archive_duration" .== threadMetadataAutoArchive + , "archive_timestamp" .== threadMetadataArchiveTime + , "locked" .== threadMetadataLocked + , "invitable" .=? threadMetadataInvitable + , "create_timestamp" .== threadMetadataCreateTime + ] + +-- | A user in a thread +data ThreadMember = ThreadMember + { threadMemberThreadId :: Maybe ChannelId -- ^ id of the thread + , threadMemberUserId :: Maybe UserId -- ^ id of the user + , threadMemberJoinTime :: UTCTime -- ^ time the current user last joined the thread + , threadMemberFlags :: Integer -- ^ user-thread settings + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMember where + parseJSON = withObject "ThreadMember" $ \o -> + ThreadMember <$> o .:? "id" + <*> o .:? "user_id" + <*> o .: "join_timestamp" + <*> o .: "flags" + +instance ToJSON ThreadMember where + toJSON ThreadMember{..} = objectFromMaybes + [ "id" .=? threadMemberThreadId + , "user_id" .=? threadMemberUserId + , "join_timestamp" .== threadMemberJoinTime + , "flags" .== threadMemberFlags + ] + + +data ThreadListSyncFields = ThreadListSyncFields + { threadListSyncFieldsGuildId :: GuildId + , threadListSyncFieldsChannelIds :: Maybe [ChannelId] + , threadListSyncFieldsThreads :: [Channel] + , threadListSyncFieldsThreadMembers :: [ThreadMember] + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadListSyncFields where + parseJSON = withObject "ThreadListSyncFields" $ \o -> + ThreadListSyncFields <$> o .: "guild_id" + <*> o .:? "channel_ids" + <*> o .: "threads" + <*> o .: "members" + +data ThreadMembersUpdateFields = ThreadMembersUpdateFields + { threadMembersUpdateFieldsThreadId :: ChannelId + , threadMembersUpdateFieldsGuildId :: GuildId + , threadMembersUpdateFieldsMemberCount :: Integer + , threadMembersUpdateFieldsAddedMembers :: Maybe [ThreadMember] + , threadMembersUpdateFieldsRemovedMembers :: Maybe [UserId] + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ThreadMembersUpdateFields where + parseJSON = withObject "ThreadMembersUpdateFields" $ \o -> + ThreadMembersUpdateFields <$> o .: "id" + <*> o .: "guild_id" + <*> o .: "member_count" + <*> o .:? "added_members" + <*> o .:? "removed_member_ids" + +-- | Represents information about a message in a Discord channel. +data Message = Message + { messageId :: MessageId -- ^ The id of the message + , messageChannelId :: ChannelId -- ^ Id of the channel the message + -- was sent in + , messageGuildId :: Maybe GuildId -- ^ The guild the message went to + , messageAuthor :: User -- ^ The 'User' the message was sent + -- by + , messageMember :: Maybe GuildMember -- ^ A partial guild member object + , messageContent :: Text -- ^ Contents of the message + , messageTimestamp :: UTCTime -- ^ When the message was sent + , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited + , messageTts :: Bool -- ^ Whether this message was a TTS + -- message + , messageEveryone :: Bool -- ^ Whether this message mentions + -- everyone + , messageMentions :: [User] -- ^ 'User's specifically mentioned in + -- the message + , messageMentionRoles :: [RoleId] -- ^ 'Role's specifically mentioned in + -- the message + , messageAttachments :: [Attachment] -- ^ Any attached files + , messageEmbeds :: [Embed] -- ^ Any embedded content + , messageReactions :: [MessageReaction] -- ^ Any reactions to message + , messageNonce :: Maybe Nonce -- ^ Used for validating if a message + -- was sent + , messagePinned :: Bool -- ^ Whether this message is pinned + , messageWebhookId :: Maybe WebhookId -- ^ The webhook id of the webhook that made the message + , messageType :: MessageType -- ^ What type of message is this. + , messageActivity :: Maybe MessageActivity -- ^ sent with Rich Presence-related chat embeds + , messageApplicationId :: Maybe ApplicationId -- ^ if the message is a response to an Interaction, this is the id of the interaction's application + , messageReference :: Maybe MessageReference -- ^ Reference IDs of the original message + , messageFlags :: Maybe MessageFlags -- ^ Various message flags + , messageReferencedMessage :: Maybe Message -- ^ The full original message + , messageInteraction :: Maybe MessageInteraction -- ^ sent if message is an interaction response + , messageThread :: Maybe Channel -- ^ the thread that was started from this message, includes thread member object + , messageComponents :: Maybe [ActionRow] -- ^ sent if the message contains components like buttons, action rows, or other interactive components + , messageStickerItems :: Maybe [StickerItem] -- ^ sent if the message contains stickers + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Message where + parseJSON = withObject "Message" $ \o -> + Message <$> o .: "id" + <*> o .: "channel_id" + <*> o .:? "guild_id" .!= Nothing + <*> (do isW <- o .:? "webhook_id" + a <- o .: "author" + case isW :: Maybe WebhookId of + Nothing -> pure a + Just _ -> pure $ a { userIsWebhook = True }) + <*> o .:? "member" + <*> o .:? "content" .!= "" + <*> o .:? "timestamp" .!= epochTime + <*> o .:? "edited_timestamp" + <*> o .:? "tts" .!= False + <*> o .:? "mention_everyone" .!= False + <*> o .:? "mentions" .!= [] + <*> o .:? "mention_roles" .!= [] + <*> o .:? "attachments" .!= [] + <*> o .: "embeds" + <*> o .:? "reactions" .!= [] + <*> o .:? "nonce" + <*> o .:? "pinned" .!= False + <*> o .:? "webhook_id" + <*> o .: "type" + <*> o .:? "activity" + -- <*> o .:? "application" + <*> o .:? "application_id" + <*> o .:? "message_reference" .!= Nothing + <*> o .:? "flags" + <*> o .:? "referenced_message" .!= Nothing + <*> o .:? "interaction" + <*> o .:? "thread" + <*> o .:? "components" + <*> o .:? "sticker_items" + + +instance ToJSON Message where + toJSON Message {..} = objectFromMaybes + [ "id" .== messageId + , "channel_id" .== messageChannelId + , "guild_id" .=? messageGuildId + , "author" .== messageAuthor + , "member" .=? messageMember + , "content" .== messageContent + , "timestamp" .== messageTimestamp + , "edited_timestamp" .=? messageEdited + , "tts" .== messageTts + , "mention_everyone" .== messageEveryone + , "mentions" .== messageMentions + , "mention_roles" .== messageMentionRoles + , "attachments" .== messageAttachments + , "embeds" .== messageEmbeds + , "reactions" .== messageReactions + , "nonce" .=? messageNonce + , "pinned" .== messagePinned + , "webhook_id" .=? messageWebhookId + , "type" .== messageType + , "activity" .=? messageActivity + -- , ("application", toJSON <$> messageApplication) + , "application_id" .=? messageApplicationId + , "message_reference" .=? messageReference + , "flags" .=? messageFlags + , "referenced_message" .=? messageReferencedMessage + , "interaction" .=? messageInteraction + , "thread" .=? messageThread + , "components" .=? messageComponents + , "sticker_items" .=? messageStickerItems + ] + +-- | Data constructor for a part of MessageDetailedOpts. +data AllowedMentions = AllowedMentions + { mentionEveryone :: Bool -- ^ Can mention @\@everyone@ + , mentionUsers :: Bool -- ^ Can mention any user + , mentionRoles :: Bool -- ^ Can mention any mentionable role + , mentionUserIds :: [UserId] -- ^ List of users able to be mentionned + , mentionRoleIds :: [RoleId] -- ^ List of roles able to be mentioneed + , mentionRepliedUser :: Bool -- ^ Can mention the sender of the replied message + } deriving (Show, Read, Eq, Ord) + +instance Default AllowedMentions where + def = AllowedMentions { mentionEveryone = False + , mentionUsers = True + , mentionRoles = True + , mentionUserIds = [] + , mentionRoleIds = [] + , mentionRepliedUser = True + } + +instance ToJSON AllowedMentions where + toJSON AllowedMentions{..} = object [ + "parse" .= [name :: T.Text | (name, True) <- + [ ("everyone", mentionEveryone), + ("users", mentionUsers && null mentionUserIds), + ("roles", mentionRoles && null mentionRoleIds) ] ], + -- https://discord.com/developers/docs/resources/channel#allowed-mentions-object + -- parse.users and users list cannot both be active, prioritize id list + "roles" .= mentionRoleIds, + "users" .= mentionUserIds, + "replied_user" .= mentionRepliedUser ] + +-- | A reaction to a message +data MessageReaction = MessageReaction + { messageReactionCount :: Int + , messageReactionMeIncluded :: Bool + , messageReactionEmoji :: Emoji + } deriving (Show, Read, Eq, Ord) + +instance FromJSON MessageReaction where + parseJSON = withObject "MessageReaction" $ \o -> + MessageReaction <$> o .: "count" + <*> o .: "me" + <*> o .: "emoji" + +instance ToJSON MessageReaction where + toJSON MessageReaction{..} = objectFromMaybes + [ "count" .== messageReactionCount + , "me" .== messageReactionMeIncluded + , "emoji" .== messageReactionEmoji + ] + +-- | Represents an attached to a message file. +data Attachment = Attachment + { attachmentId :: AttachmentId -- ^ Attachment id + , attachmentFilename :: T.Text -- ^ Name of attached file + , attachmentSize :: Integer -- ^ Size of file (in bytes) + , attachmentUrl :: T.Text -- ^ Source of file + , attachmentProxy :: T.Text -- ^ Proxied url of file + , attachmentHeight :: Maybe Integer -- ^ Height of file (if image) + , attachmentWidth :: Maybe Integer -- ^ Width of file (if image) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Attachment where + parseJSON = withObject "Attachment" $ \o -> + Attachment <$> o .: "id" + <*> o .: "filename" + <*> o .: "size" + <*> o .: "url" + <*> o .: "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +instance ToJSON Attachment where + toJSON Attachment {..} = objectFromMaybes + [ "id" .== attachmentId + , "filename" .== attachmentFilename + , "size" .== attachmentSize + , "url" .== attachmentUrl + , "proxy_url" .== attachmentProxy + , "height" .=? attachmentHeight + , "width" .=? attachmentWidth + ] + +newtype Nonce = Nonce T.Text + deriving (Show, Read, Eq, Ord) + +instance FromJSON Nonce where + parseJSON (String nonce) = pure $ Nonce nonce + parseJSON (Number nonce) = pure . Nonce . T.pack . show $ nonce + parseJSON _ = empty + +instance ToJSON Nonce where + toJSON (Nonce t) = String t + + +-- | Represents a Message Reference +data MessageReference = MessageReference + { referenceMessageId :: Maybe MessageId -- ^ id of the originating message + , referenceChannelId :: Maybe ChannelId -- ^ id of the originating message's channel + , referenceGuildId :: Maybe GuildId -- ^ id of the originating message's guild + , failIfNotExists :: Bool -- ^ Whether to not send if reference not exist + } deriving (Show, Read, Eq, Ord) + +instance FromJSON MessageReference where + parseJSON = withObject "MessageReference" $ \o -> + MessageReference <$> o .:? "message_id" + <*> o .:? "channel_id" + <*> o .:? "guild_id" + <*> o .:? "fail_if_not_exists" .!= True + +instance ToJSON MessageReference where + toJSON MessageReference{..} = objectFromMaybes + [ "message_id" .== referenceMessageId + , "channel_id" .== referenceChannelId + , "guild_id" .== referenceGuildId + , "fail_if_not_exists" .== failIfNotExists + ] + +instance Default MessageReference where + def = MessageReference { referenceMessageId = Nothing + , referenceChannelId = Nothing + , referenceGuildId = Nothing + , failIfNotExists = False + } + + +data MessageType + = MessageTypeDefault + | MessageTypeRecipientAdd + | MessageTypeRecipientRemove + | MessageTypeCall + | MessageTypeChannelNameChange + | MessageTypeChannelIconChange + | MessageTypeChannelPinnedMessage + | MessageTypeGuildMemberJoin + | MessageTypeUserPremiumGuildSubscription + | MessageTypeUserPremiumGuildSubscriptionTier1 + | MessageTypeUserPremiumGuildSubscriptionTier2 + | MessageTypeUserPremiumGuildSubscriptionTier3 + | MessageTypeChannelFollowAdd + | MessageTypeGuildDiscoveryDisqualified + | MessageTypeGuildDiscoveryRequalified + | MessageTypeGuildDiscoveryGracePeriodInitialWarning + | MessageTypeGuildDiscoveryGracePeriodFinalWarning + | MessageTypeThreadCreated + | MessageTypeReply + | MessageTypeChatInputCommand + | MessageTypeThreadStarterMessage + | MessageTypeGuildInviteReminder + | MessageTypeContextMenuCommand + deriving (Show, Read, Data, Eq, Ord) + +instance InternalDiscordEnum MessageType where + discordTypeStartValue = MessageTypeDefault + fromDiscordType MessageTypeDefault = 0 + fromDiscordType MessageTypeRecipientAdd = 1 + fromDiscordType MessageTypeRecipientRemove = 2 + fromDiscordType MessageTypeCall = 3 + fromDiscordType MessageTypeChannelNameChange = 4 + fromDiscordType MessageTypeChannelIconChange = 5 + fromDiscordType MessageTypeChannelPinnedMessage = 6 + fromDiscordType MessageTypeGuildMemberJoin = 7 + fromDiscordType MessageTypeUserPremiumGuildSubscription = 8 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier1 = 9 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier2 = 10 + fromDiscordType MessageTypeUserPremiumGuildSubscriptionTier3 = 11 + fromDiscordType MessageTypeChannelFollowAdd = 12 + fromDiscordType MessageTypeGuildDiscoveryDisqualified = 14 + fromDiscordType MessageTypeGuildDiscoveryRequalified = 15 + fromDiscordType MessageTypeGuildDiscoveryGracePeriodInitialWarning = 16 + fromDiscordType MessageTypeGuildDiscoveryGracePeriodFinalWarning = 17 + fromDiscordType MessageTypeThreadCreated = 18 + fromDiscordType MessageTypeReply = 19 + fromDiscordType MessageTypeChatInputCommand = 20 + fromDiscordType MessageTypeThreadStarterMessage = 21 + fromDiscordType MessageTypeGuildInviteReminder = 22 + fromDiscordType MessageTypeContextMenuCommand = 23 + +instance ToJSON MessageType where + toJSON = toJSON . fromDiscordType + +instance FromJSON MessageType where + parseJSON = discordTypeParseJSON "MessageType" + +data MessageActivity = MessageActivity + { messageActivityType :: MessageActivityType + , messageActivityPartyId :: Maybe T.Text + } + deriving (Show, Read, Data, Eq, Ord) + +instance FromJSON MessageActivity where + parseJSON = withObject "MessageActivity" $ \o -> + MessageActivity <$> o .: "type" + <*> o .:? "party_id" + +instance ToJSON MessageActivity where + toJSON MessageActivity{..} = objectFromMaybes + [ "type" .== messageActivityType + , "party_id" .=? messageActivityPartyId + ] + +data MessageActivityType + = MessageActivityTypeJoin -- ^ Join a Rich Presence event + | MessageActivityTypeSpectate -- ^ Spectate a Rich Presence event + | MessageActivityTypeListen -- ^ Listen to a Rich Presence event + | MessageActivityTypeJoinRequest -- ^ Request to join a Rich Presence event + deriving (Show, Read, Data, Eq, Ord) + +instance InternalDiscordEnum MessageActivityType where + discordTypeStartValue = MessageActivityTypeJoin + fromDiscordType MessageActivityTypeJoin = 1 + fromDiscordType MessageActivityTypeSpectate = 2 + fromDiscordType MessageActivityTypeListen = 3 + fromDiscordType MessageActivityTypeJoinRequest = 4 + +instance ToJSON MessageActivityType where + toJSON = toJSON . fromDiscordType + +instance FromJSON MessageActivityType where + parseJSON = discordTypeParseJSON "MessageActivityType" + +-- | Types of flags to attach to the message. +data MessageFlag = + MessageFlagCrossposted + | MessageFlagIsCrosspost + | MessageFlagSupressEmbeds + | MessageFlagSourceMessageDeleted + | MessageFlagUrgent + | MessageFlagHasThread + | MessageFlagEphemeral + | MessageFlagLoading + | MessageFlagFailedToMentionRollesInThread + deriving (Show, Read, Eq, Data, Ord) + +newtype MessageFlags = MessageFlags [MessageFlag] + deriving (Show, Read, Eq, Ord) + +instance InternalDiscordEnum MessageFlag where + discordTypeStartValue = MessageFlagCrossposted + fromDiscordType MessageFlagCrossposted = 1 `shift` 0 + fromDiscordType MessageFlagIsCrosspost = 1 `shift` 1 + fromDiscordType MessageFlagSupressEmbeds = 1 `shift` 2 + fromDiscordType MessageFlagSourceMessageDeleted = 1 `shift` 3 + fromDiscordType MessageFlagUrgent = 1 `shift` 4 + fromDiscordType MessageFlagHasThread = 1 `shift` 5 + fromDiscordType MessageFlagEphemeral = 1 `shift` 6 + fromDiscordType MessageFlagLoading = 1 `shift` 7 + fromDiscordType MessageFlagFailedToMentionRollesInThread = 1 `shift` 8 + +instance ToJSON MessageFlags where + toJSON (MessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromDiscordType <$> fs) + +-- TODO: maybe make this a type class or something - the ability to handle flags automatically would be Very Good. + +instance FromJSON MessageFlags where + parseJSON = withScientific "MessageFlags" $ \s -> + let i = round s + -- TODO check to see that we know about all the flags + -- if i /= (i .&. range) + -- range = sum $ fst <$> (discordTypeTable @MessageFlag) + in return $ MessageFlags (snd <$> filter (\(i',_) -> i .&. i' == i') discordTypeTable) + +-- | This is sent on the message object when the message is a response to an Interaction without an existing message (i.e., any non-component interaction). +data MessageInteraction = MessageInteraction + { messageInteractionId :: InteractionId -- ^ Id of the interaction + , messageInteractionType :: Integer -- ^ Type of the interaction (liekly always application command) + , messageInteractionName :: T.Text -- ^ Name of the interaction + , messageInteractionUser :: User -- ^ User who invoked the interaction + } deriving (Show, Read, Eq, Ord) + +instance ToJSON MessageInteraction where + toJSON MessageInteraction{..} = objectFromMaybes + [ "id" .== messageInteractionId + , "type" .== messageInteractionType + , "name" .== messageInteractionName + , "user" .== messageInteractionUser + ] + +instance FromJSON MessageInteraction where + parseJSON = withObject "MessageInteraction" $ \o -> + MessageInteraction <$> o .: "id" + <*> o .: "type" + <*> o .: "name" + <*> o .: "user" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Color.hs b/deps/discord-haskell/src/Discord/Internal/Types/Color.hs new file mode 100644 index 0000000..09f7890 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Color.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Data structures pertaining to Discord Colors +module Discord.Internal.Types.Color where + + +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) +import Data.Char (toLower) +import Data.Aeson +import Data.Data +import Control.Applicative (Alternative((<|>))) +import Data.Bits (Bits((.&.))) + + +import Discord.Internal.Types.Prelude (InternalDiscordEnum(..)) + +-- | Color names +-- Color is a bit of a mess on discord embeds. +-- I've here stolen the pallet list from https://gist.github.com/thomasbnt/b6f455e2c7d743b796917fa3c205f812 +-- +-- All discord embed color stuff is credited to +-- https://github.com/WarwickTabletop/tablebot/pull/34 +data DiscordColor + = -- | An RGB color with values in @[0..255]@ + DiscordColorRGB Integer Integer Integer + | DiscordColorDefault + | DiscordColorAqua + | DiscordColorDarkAqua + | DiscordColorGreen + | DiscordColorDarkGreen + | DiscordColorBlue + | DiscordColorDarkBlue + | DiscordColorPurple + | DiscordColorDarkPurple + | DiscordColorLuminousVividPink + | DiscordColorDarkVividPink + | DiscordColorGold + | DiscordColorDarkGold + | DiscordColorOrange + | DiscordColorDarkOrange + | DiscordColorRed + | DiscordColorDarkRed + | DiscordColorGray + | DiscordColorDarkGray + | DiscordColorDarkerGray + | DiscordColorLightGray + | DiscordColorNavy + | DiscordColorDarkNavy + | DiscordColorYellow + | DiscordColorDiscordWhite + | DiscordColorDiscordBlurple + | DiscordColorDiscordGrayple + | DiscordColorDiscordDarkButNotBlack + | DiscordColorDiscordNotQuiteBlack + | DiscordColorDiscordGreen + | DiscordColorDiscordYellow + | DiscordColorDiscordFuschia + | DiscordColorDiscordRed + | DiscordColorDiscordBlack + deriving (Show, Read, Eq, Ord, Data) + +-- | @hexToRGB@ attempts to convert a potential hex string into its decimal RGB +-- components. +hexToRGB :: String -> Maybe (Integer, Integer, Integer) +hexToRGB hex = do + let h = map toLower hex + r <- take2 h >>= toDec + g <- drop2 h >>= take2 >>= toDec + b <- drop2 h >>= drop2 >>= toDec + return (r, g, b) + where + take2 (a:b:_) = Just [a, b] + take2 _ = Nothing + drop2 (_ : _ : as) = Just as + drop2 _ = Nothing + toDec :: String -> Maybe Integer + toDec [s, u] = do + a <- charToDec s + b <- charToDec u + return $ a * 16 + b + toDec _ = Nothing + charToDec :: Char -> Maybe Integer + charToDec 'a' = Just 10 + charToDec 'b' = Just 11 + charToDec 'c' = Just 12 + charToDec 'd' = Just 13 + charToDec 'e' = Just 14 + charToDec 'f' = Just 15 + charToDec c = readMaybe [c] + +-- | @hexToDiscordColor@ converts a potential hex string into a DiscordColor, +-- evaluating to Default if it fails. +hexToDiscordColor :: String -> DiscordColor +hexToDiscordColor hex = + let (r, g, b) = fromMaybe (0, 0, 0) $ hexToRGB hex + in DiscordColorRGB r g b + +-- | Convert a color to its internal `Integer` representation +colorToInternal :: DiscordColor -> Integer +-- colorToInternal (DiscordColor i) = i +colorToInternal (DiscordColorRGB r g b) = (r * 256 + g) * 256 + b +colorToInternal DiscordColorDefault = 0 +colorToInternal DiscordColorAqua = 1752220 +colorToInternal DiscordColorDarkAqua = 1146986 +colorToInternal DiscordColorGreen = 3066993 +colorToInternal DiscordColorDarkGreen = 2067276 +colorToInternal DiscordColorBlue = 3447003 +colorToInternal DiscordColorDarkBlue = 2123412 +colorToInternal DiscordColorPurple = 10181046 +colorToInternal DiscordColorDarkPurple = 7419530 +colorToInternal DiscordColorLuminousVividPink = 15277667 +colorToInternal DiscordColorDarkVividPink = 11342935 +colorToInternal DiscordColorGold = 15844367 +colorToInternal DiscordColorDarkGold = 12745742 +colorToInternal DiscordColorOrange = 15105570 +colorToInternal DiscordColorDarkOrange = 11027200 +colorToInternal DiscordColorRed = 15158332 +colorToInternal DiscordColorDarkRed = 10038562 +colorToInternal DiscordColorGray = 9807270 +colorToInternal DiscordColorDarkGray = 9936031 +colorToInternal DiscordColorDarkerGray = 8359053 +colorToInternal DiscordColorLightGray = 12370112 +colorToInternal DiscordColorNavy = 3426654 +colorToInternal DiscordColorDarkNavy = 2899536 +colorToInternal DiscordColorYellow = 16776960 +colorToInternal DiscordColorDiscordWhite = 16777215 +colorToInternal DiscordColorDiscordBlurple = 5793266 +colorToInternal DiscordColorDiscordGrayple = 10070709 +colorToInternal DiscordColorDiscordDarkButNotBlack = 2895667 +colorToInternal DiscordColorDiscordNotQuiteBlack = 2303786 +colorToInternal DiscordColorDiscordGreen = 5763719 +colorToInternal DiscordColorDiscordYellow = 16705372 +colorToInternal DiscordColorDiscordFuschia = 15418782 +colorToInternal DiscordColorDiscordRed = 15548997 +colorToInternal DiscordColorDiscordBlack = 16777215 + +-- | Convert a color integer to a RGB color with values in @[0..255]@ +convertToRGB :: Integer -> DiscordColor +convertToRGB i = DiscordColorRGB (div i (256 * 256) .&. 255) (div i 256 .&. 255) (i .&. 255) + +instance InternalDiscordEnum DiscordColor where + discordTypeStartValue = DiscordColorDefault + fromDiscordType = fromIntegral . colorToInternal + discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map (fromConstrB (fromConstr (toConstr (0 :: Int)))) (dataTypeConstrs $ dataTypeOf t) + +instance ToJSON DiscordColor where + toJSON = toJSON . fromDiscordType + +instance FromJSON DiscordColor where + parseJSON = + withScientific + "DiscordColor" + ( \v -> + discordTypeParseJSON "DiscordColor" (Number v) + <|> ( case maybeInt v >>= Just . convertToRGB of + Nothing -> fail $ "could not parse discord color: " ++ show v + Just d -> return d + ) + ) + where + maybeInt i + | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Components.hs b/deps/discord-haskell/src/Discord/Internal/Types/Components.hs new file mode 100644 index 0000000..16bb0c6 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Components.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Message components +module Discord.Internal.Types.Components + ( ActionRow (..), + Button (..), + ButtonStyle (..), + mkButton, + SelectMenu (..), + mkSelectMenu, + SelectMenuData (..), + SelectOption (..), + mkSelectOption, + TextInput (..), + mkTextInput, + ) +where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Foldable (Foldable (toList)) +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Discord.Internal.Types.Emoji (Emoji) +import Discord.Internal.Types.Prelude (objectFromMaybes, (.==), (.=?), ChannelTypeOption) + +-- | Container for other message Components +data ActionRow = ActionRowButtons [Button] | ActionRowSelectMenu SelectMenu + deriving (Show, Read, Eq, Ord) + +instance FromJSON ActionRow where + parseJSON = + withObject + "ActionRow" + ( \cs -> do + t <- cs .: "type" :: Parser Int + case t of + 1 -> do + a <- cs .: "components" :: Parser Array + let a' = toList a + case a' of + [] -> return $ ActionRowButtons [] + (c : _) -> + withObject + "ActionRow item" + ( \v -> do + t' <- v .: "type" :: Parser Int + case t' of + 2 -> ActionRowButtons <$> mapM parseJSON a' + _ | t' `elem` [3, 5, 6, 7, 8] -> ActionRowSelectMenu <$> parseJSON c + _ -> fail $ "unknown component type: " ++ show t' + ) + c + _ -> fail $ "expected action row type (1), got: " ++ show t + ) + +instance ToJSON ActionRow where + toJSON (ActionRowButtons bs) = object [("type", Number 1), ("components", toJSON bs)] + toJSON (ActionRowSelectMenu bs) = object [("type", Number 1), ("components", toJSON [bs])] + +-- | Component type for a button, split into URL button and not URL button. +-- +-- Don't directly send button components - they need to be within an action row. +data Button + = Button + { -- | Dev indentifier + buttonCustomId :: T.Text, + -- | Whether the button is disabled + buttonDisabled :: Bool, + -- | What is the style of the button + buttonStyle :: ButtonStyle, + -- | What is the user-facing label of the button + buttonLabel :: Maybe T.Text, + -- | What emoji is displayed on the button + buttonEmoji :: Maybe Emoji + } + | ButtonUrl + { -- | The url for the button. If this is not a valid url, everything will + -- break + buttonUrl :: T.Text, + -- | Whether the button is disabled + buttonDisabled :: Bool, + -- | What is the user-facing label of the button + buttonLabel :: Maybe T.Text, + -- | What emoji is displayed on the button + buttonEmoji :: Maybe Emoji + } + deriving (Show, Read, Eq, Ord) + +-- | Takes the label and the custom id of the button that is to be generated. +mkButton :: T.Text -> T.Text -> Button +mkButton label customId = Button customId False ButtonStyleSecondary (Just label) Nothing + +instance FromJSON Button where + parseJSON = + withObject + "Button" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> do + disabled <- v .:? "disabled" .!= False + label <- v .:? "label" + partialEmoji <- v .:? "emoji" + style <- v .: "style" :: Parser Scientific + case style of + 5 -> + ButtonUrl + <$> v .: "url" + <*> return disabled + <*> return label + <*> return partialEmoji + _ -> + Button + <$> v .: "custom_id" + <*> return disabled + <*> parseJSON (Number style) + <*> return label + <*> return partialEmoji + _ -> fail "expected button type, got a different component" + ) + +instance ToJSON Button where + toJSON ButtonUrl {..} = + objectFromMaybes + [ "type" .== Number 2, + "style" .== Number 5, + "label" .=? buttonLabel, + "disabled" .== buttonDisabled, + "url" .== buttonUrl, + "emoji" .=? buttonEmoji + ] + toJSON Button {..} = + objectFromMaybes + [ "type" .== Number 2, + "style" .== buttonStyle, + "label" .=? buttonLabel, + "disabled" .== buttonDisabled, + "custom_id" .== buttonCustomId, + "emoji" .=? buttonEmoji + ] + +-- | Buttton colors. +data ButtonStyle + = -- | Blurple button + ButtonStylePrimary + | -- | Grey button + ButtonStyleSecondary + | -- | Green button + ButtonStyleSuccess + | -- | Red button + ButtonStyleDanger + deriving (Show, Read, Eq, Ord) + +instance FromJSON ButtonStyle where + parseJSON = + withScientific + "ButtonStyle" + ( \case + 1 -> return ButtonStylePrimary + 2 -> return ButtonStyleSecondary + 3 -> return ButtonStyleSuccess + 4 -> return ButtonStyleDanger + _ -> fail "unrecognised non-url button style" + ) + +instance ToJSON ButtonStyle where + toJSON ButtonStylePrimary = Number 1 + toJSON ButtonStyleSecondary = Number 2 + toJSON ButtonStyleSuccess = Number 3 + toJSON ButtonStyleDanger = Number 4 + +-- | Component type for a select menu. +-- +-- Don't directly send select menus - they need to be within an action row. +data SelectMenu = SelectMenu + { -- | Dev identifier + selectMenuCustomId :: T.Text, + -- | Whether the select menu is disabled + selectMenuDisabled :: Bool, + -- | What type this select menu is, and the data it can hold + selectMenuData :: SelectMenuData, + -- | Placeholder text if nothing is selected + selectMenuPlaceholder :: Maybe T.Text, + -- | Minimum number of values to select (def 1, min 0, max 25) + selectMenuMinValues :: Maybe Integer, + -- | Maximum number of values to select (def 1, max 25) + selectMenuMaxValues :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) + +-- | Takes the custom id and the options of the select menu that is to be +-- generated. +mkSelectMenu :: T.Text -> [SelectOption] -> SelectMenu +mkSelectMenu customId sos = SelectMenu customId False (SelectMenuDataText sos) Nothing Nothing Nothing + +instance FromJSON SelectMenu where + parseJSON = + withObject + "SelectMenu" + $ \v -> + do + SelectMenu + <$> v .: "custom_id" + <*> v .:? "disabled" .!= False + <*> parseJSON (Object v) + <*> v .:? "placeholder" + <*> v .:? "min_values" + <*> v .:? "max_values" + + +instance ToJSON SelectMenu where + toJSON SelectMenu {..} = + objectFromMaybes $ + [ "custom_id" .== selectMenuCustomId, + "disabled" .== selectMenuDisabled, + "placeholder" .=? selectMenuPlaceholder, + "min_values" .=? selectMenuMinValues, + "max_values" .=? selectMenuMaxValues + ] <> case selectMenuData of + SelectMenuDataText sos -> ["type" .== Number 3, "options" .== sos] + SelectMenuDataUser -> ["type" .== Number 5] + SelectMenuDataRole -> ["type" .== Number 6] + SelectMenuDataMentionable -> ["type" .== Number 7] + SelectMenuDataChannels ctos -> ["type" .== Number 8, "channel_types" .== ctos] + +data SelectMenuData = + SelectMenuDataText [SelectOption] -- ^ Text options + | SelectMenuDataUser -- ^ Users + | SelectMenuDataRole -- ^ Roles + | SelectMenuDataMentionable -- ^ Anything mentionable (users and roles) + | SelectMenuDataChannels [ChannelTypeOption] -- ^ Channels (of certain types) + deriving (Show, Read, Eq, Ord) + +instance FromJSON SelectMenuData where + parseJSON = + withObject "SelectMenuData" $ \v -> + do + t <- v .: "type" + case t::Int of + 3 -> SelectMenuDataText <$> v .: "options" + 5 -> pure SelectMenuDataUser + 6 -> pure SelectMenuDataRole + 7 -> pure SelectMenuDataMentionable + 8 -> SelectMenuDataChannels <$> v .: "channel_types" + _ -> fail ("unknown select menu data type: " <> show t) + +-- | A single option in a select menu. +data SelectOption = SelectOption + { -- | User facing option name + selectOptionLabel :: T.Text, + -- | Dev facing option value + selectOptionValue :: T.Text, + -- | additional description + selectOptionDescription :: Maybe T.Text, + -- | A partial emoji to show with the object (id, name, animated) + selectOptionEmoji :: Maybe Emoji, + -- | Use this value by default + selectOptionDefault :: Maybe Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Make a select option from the given label and value. +mkSelectOption :: T.Text -> T.Text -> SelectOption +mkSelectOption label value = SelectOption label value Nothing Nothing Nothing + +instance FromJSON SelectOption where + parseJSON = withObject "SelectOption" $ \o -> + SelectOption <$> o .: "label" + <*> o .: "value" + <*> o .:? "description" + <*> o .:? "emoji" + <*> o .:? "default" + +instance ToJSON SelectOption where + toJSON SelectOption {..} = + objectFromMaybes + [ "label" .== selectOptionLabel, + "value" .== selectOptionValue, + "description" .=? selectOptionDescription, + "emoji" .=? selectOptionEmoji, + "default" .=? selectOptionDefault + ] + +data TextInput = TextInput + { -- | Dev identifier + textInputCustomId :: T.Text, + -- | What style to use (short or paragraph) + textInputIsParagraph :: Bool, + -- | The label for this component + textInputLabel :: T.Text, + -- | The minimum input length for a text input (0-4000) + textInputMinLength :: Maybe Integer, + -- | The maximum input length for a text input (1-4000) + textInputMaxLength :: Maybe Integer, + -- | Whether this component is required to be filled + textInputRequired :: Bool, + -- | The prefilled value for this component (max 4000) + textInputValue :: T.Text, + -- | Placeholder text if empty (max 4000) + textInputPlaceholder :: T.Text + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON TextInput where + toJSON TextInput {..} = + objectFromMaybes + [ "type" .== Number 4, + "custom_id" .== textInputCustomId, + "style" .== (1 + fromEnum textInputIsParagraph), + "label" .== textInputLabel, + "min_length" .=? textInputMinLength, + "max_length" .=? textInputMaxLength, + "required" .== textInputRequired, + "value" .== textInputValue, + "placeholder" .== textInputPlaceholder + ] + +instance FromJSON TextInput where + parseJSON = withObject "TextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 4 -> + TextInput <$> o .: "custom_id" + <*> fmap (== (2 :: Int)) (o .:? "style" .!= 1) + <*> o .:? "label" .!= "" + <*> o .:? "min_length" + <*> o .:? "max_length" + <*> o .:? "required" .!= False + <*> o .:? "value" .!= "" + <*> o .:? "placeholder" .!= "" + _ -> fail "expected text input, found other type of component" + +-- | Create a text input from an id and a label +mkTextInput :: T.Text -> T.Text -> TextInput +mkTextInput cid label = TextInput cid False label Nothing Nothing True "" "" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Embed.hs b/deps/discord-haskell/src/Discord/Internal/Types/Embed.hs new file mode 100644 index 0000000..6700911 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Embed.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures pertaining to Discord Embed +module Discord.Internal.Types.Embed where + +import Data.Aeson +import Data.Time.Clock +import Data.Default (Default, def) +import qualified Data.Text as T +import qualified Data.ByteString as B +import Data.Functor ((<&>)) + +import Network.HTTP.Client.MultipartFormData (PartM, partFileRequestBody) +import Network.HTTP.Client (RequestBody(RequestBodyBS)) + +import Discord.Internal.Types.Color (DiscordColor) + +createEmbed :: CreateEmbed -> Embed +createEmbed CreateEmbed{..} = + let + emptyMaybe :: T.Text -> Maybe T.Text + emptyMaybe t = if T.null t then Nothing else Just t + + embedImageToUrl :: T.Text -> CreateEmbedImage -> T.Text + embedImageToUrl place cei = case cei of + CreateEmbedImageUrl t -> t + CreateEmbedImageUpload _ -> T.filter (/=' ') $ "attachment://" <> createEmbedTitle <> place <> ".png" + + embedAuthor = EmbedAuthor createEmbedAuthorName + (emptyMaybe createEmbedAuthorUrl) + (embedImageToUrl "author" <$> createEmbedAuthorIcon) + Nothing + embedImage = (embedImageToUrl "image" <$> createEmbedImage) <&> + \image -> EmbedImage image Nothing Nothing Nothing + embedThumbnail = (embedImageToUrl "thumbnail" <$> createEmbedThumbnail) <&> + \thumbnail -> EmbedThumbnail thumbnail Nothing Nothing Nothing + embedFooter = EmbedFooter createEmbedFooterText + (embedImageToUrl "footer" <$> createEmbedFooterIcon) + Nothing + + in Embed { embedAuthor = Just embedAuthor + , embedTitle = emptyMaybe createEmbedTitle + , embedUrl = emptyMaybe createEmbedUrl + , embedThumbnail = embedThumbnail + , embedDescription = emptyMaybe createEmbedDescription + , embedFields = createEmbedFields + , embedImage = embedImage + , embedFooter = Just embedFooter + , embedColor = createEmbedColor + , embedTimestamp = createEmbedTimestamp + + -- can't set these + , embedVideo = Nothing + , embedProvider = Nothing + } + +data CreateEmbed = CreateEmbed + { createEmbedAuthorName :: T.Text + , createEmbedAuthorUrl :: T.Text + , createEmbedAuthorIcon :: Maybe CreateEmbedImage + , createEmbedTitle :: T.Text + , createEmbedUrl :: T.Text + , createEmbedThumbnail :: Maybe CreateEmbedImage + , createEmbedDescription :: T.Text + , createEmbedFields :: [EmbedField] + , createEmbedImage :: Maybe CreateEmbedImage + , createEmbedFooterText :: T.Text + , createEmbedFooterIcon :: Maybe CreateEmbedImage + , createEmbedColor :: Maybe DiscordColor + , createEmbedTimestamp :: Maybe UTCTime + } deriving (Show, Read, Eq, Ord) + +data CreateEmbedImage = CreateEmbedImageUrl T.Text + | CreateEmbedImageUpload B.ByteString + deriving (Show, Read, Eq, Ord) + +instance Default CreateEmbed where + def = CreateEmbed "" "" Nothing "" "" Nothing "" [] Nothing "" Nothing Nothing Nothing + +-- | An embed attached to a message. +data Embed = Embed + { embedAuthor :: Maybe EmbedAuthor + , embedTitle :: Maybe T.Text -- ^ Title of the embed + , embedUrl :: Maybe T.Text -- ^ URL of embed + , embedThumbnail :: Maybe EmbedThumbnail -- ^ Thumbnail in top-right + , embedDescription :: Maybe T.Text -- ^ Description of embed + , embedFields :: [EmbedField] -- ^ Fields of the embed + , embedImage :: Maybe EmbedImage + , embedFooter :: Maybe EmbedFooter + , embedColor :: Maybe DiscordColor -- ^ The embed color + , embedTimestamp :: Maybe UTCTime -- ^ The time of the embed content + , embedVideo :: Maybe EmbedVideo -- ^ Only present for "video" types + , embedProvider :: Maybe EmbedProvider -- ^ Only present for "video" types + } deriving (Show, Read, Eq, Ord) + +-- TODO +instance ToJSON Embed where + toJSON Embed{..} = object + [ "author" .= embedAuthor + , "title" .= embedTitle + , "url" .= embedUrl + , "description" .= embedDescription + , "thumbnail" .= embedThumbnail + , "fields" .= embedFields + , "image" .= embedImage + , "footer" .= embedFooter + , "color" .= embedColor + , "timestamp" .= embedTimestamp + , "video" .= embedVideo + , "provider" .= embedProvider + ] + +instance FromJSON Embed where + parseJSON = withObject "embed" $ \o -> + Embed <$> o .:? "author" + <*> o .:? "title" + <*> o .:? "url" + <*> o .:? "thumbnail" + <*> o .:? "description" + <*> o .:? "fields" .!= [] + <*> o .:? "image" + <*> o .:? "footer" + <*> o .:? "color" + <*> o .:? "timestamp" + <*> o .:? "video" + <*> o .:? "provider" + + +data EmbedThumbnail = EmbedThumbnail + { embedThumbnailUrl :: T.Text + , embedThumbnailProxyUrl :: Maybe T.Text + , embedThumbnailHeight :: Maybe Integer + , embedThumbnailWidth :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedThumbnail where + toJSON (EmbedThumbnail a b c d) = object + [ "url" .= a + , "proxy_url" .= b + , "height" .= c + , "width" .= d + ] + +instance FromJSON EmbedThumbnail where + parseJSON = withObject "thumbnail" $ \o -> + EmbedThumbnail <$> o .: "url" + <*> o .:? "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +data EmbedVideo = EmbedVideo + { embedVideoUrl :: Maybe T.Text + , embedProxyUrl :: Maybe T.Text + , embedVideoHeight :: Maybe Integer + , embedVideoWidth :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedVideo where + toJSON (EmbedVideo a a' b c) = object + [ "url" .= a + , "height" .= b + , "width" .= c + , "proxy_url" .= a' + ] + +instance FromJSON EmbedVideo where + parseJSON = withObject "video" $ \o -> + EmbedVideo <$> o .:? "url" + <*> o .:? "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +data EmbedImage = EmbedImage + { embedImageUrl :: T.Text + , embedImageProxyUrl :: Maybe T.Text + , embedImageHeight :: Maybe Integer + , embedImageWidth :: Maybe Integer + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedImage where + toJSON (EmbedImage a b c d) = object + [ "url" .= a + , "proxy_url" .= b + , "height" .= c + , "width" .= d + ] + +instance FromJSON EmbedImage where + parseJSON = withObject "image" $ \o -> + EmbedImage <$> o .: "url" + <*> o .:? "proxy_url" + <*> o .:? "height" + <*> o .:? "width" + +data EmbedProvider = EmbedProvider + { embedProviderName :: Maybe T.Text + , embedProviderUrl :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedProvider where + toJSON (EmbedProvider a b) = object + [ "name" .= a + , "url" .= b + ] + +instance FromJSON EmbedProvider where + parseJSON = withObject "provider" $ \o -> + EmbedProvider <$> o .:? "name" + <*> o .:? "url" + +data EmbedAuthor = EmbedAuthor + { embedAuthorName :: T.Text + , embedAuthorUrl :: Maybe T.Text + , embedAuthorIconUrl :: Maybe T.Text + , embedAuthorProxyIconUrl :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedAuthor where + toJSON (EmbedAuthor a b c d) = object + [ "name" .= a + , "url" .= b + , "icon_url" .= c + , "proxy_icon_url" .= d + ] + +instance FromJSON EmbedAuthor where + parseJSON = withObject "author" $ \o -> + EmbedAuthor <$> o .: "name" + <*> o .:? "url" + <*> o .:? "icon_url" + <*> o .:? "proxy_icon_url" + +data EmbedFooter = EmbedFooter + { embedFooterText :: T.Text + , embedFooterIconUrl :: Maybe T.Text + , embedFooterProxyIconUrl :: Maybe T.Text + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedFooter where + toJSON (EmbedFooter a b c) = object + [ "text" .= a + , "icon_url" .= b + , "proxy_icon_url" .= c + ] + +instance FromJSON EmbedFooter where + parseJSON = withObject "footer" $ \o -> + EmbedFooter <$> o .: "text" + <*> o .:? "icon_url" + <*> o .:? "proxy_icon_url" + +data EmbedField = EmbedField + { embedFieldName :: T.Text + , embedFieldValue :: T.Text + , embedFieldInline :: Maybe Bool + } deriving (Show, Read, Eq, Ord) + +instance ToJSON EmbedField where + toJSON (EmbedField a b c) = object + [ "name" .= a + , "value" .= b + , "inline" .= c + ] + +instance FromJSON EmbedField where + parseJSON = withObject "field" $ \o -> + EmbedField <$> o .: "name" + <*> o .: "value" + <*> o .:? "inline" + + +maybeEmbed :: Maybe CreateEmbed -> [PartM IO] +maybeEmbed = + let mkPart (name,content) = partFileRequestBody name (T.unpack name) (RequestBodyBS content) + uploads CreateEmbed{..} = [(T.filter (/=' ') $ createEmbedTitle<>n,c) | (n, Just (CreateEmbedImageUpload c)) <- + [ ("author.png", createEmbedAuthorIcon) + , ("thumbnail.png", createEmbedThumbnail) + , ("image.png", createEmbedImage) + , ("footer.png", createEmbedFooterIcon) ]] + in maybe [] (map mkPart . uploads) diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs new file mode 100644 index 0000000..9023d4a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Emoji.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Emoji where + +import Data.Aeson +import Data.Data +import Data.Functor ((<&>)) +import Data.Text as T +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.User + +-- | Represents an emoticon (emoji) +data Emoji = Emoji + { -- | The emoji id + emojiId :: Maybe EmojiId, + -- | The emoji name + emojiName :: T.Text, + -- | Roles the emoji is active for + emojiRoles :: Maybe [RoleId], + -- | User that created this emoji + emojiUser :: Maybe User, + -- | Whether this emoji is managed + emojiManaged :: Maybe Bool, + -- | Whether this emoji is animated + emojiAnimated :: Maybe Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Make an emoji with only a name +mkEmoji :: T.Text -> Emoji +mkEmoji t = Emoji Nothing t Nothing Nothing Nothing Nothing + +instance FromJSON Emoji where + parseJSON = withObject "Emoji" $ \o -> + Emoji <$> o .:? "id" + <*> o .: "name" + <*> o .:? "roles" + <*> o .:? "user" + <*> o .:? "managed" + <*> o .:? "animated" + +instance ToJSON Emoji where + toJSON Emoji {..} = + objectFromMaybes + [ "id" .=? emojiId, + "name" .== emojiName, + "roles" .=? emojiRoles, + "user" .=? emojiUser, + "managed" .=? emojiManaged, + "animated" .=? emojiAnimated + ] + +-- | Represents a pack of standard stickers. +data StickerPack = StickerPack + { -- | The id of the sticker pack + stickerPackId :: Snowflake, + -- | The stickers in the pack + stickerPackStickers :: [Sticker], + -- | The name of the sticker pack + stickerPackName :: T.Text, + -- | ID of the pack's SKU + stickerPackSKUId :: Snowflake, + -- | If of the sticker which is shown as the pack's icon + stickerPackCoverStickerId :: Maybe StickerId, + -- | The description of the sticker pack + stickerPackDescription :: T.Text, + -- | Id of the sticker pack's banner image + stickerPackBannerAssetId :: Maybe Snowflake + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON StickerPack where + parseJSON = withObject "StickerPack" $ \o -> + StickerPack <$> o .: "id" + <*> o .: "stickers" + <*> o .: "name" + <*> o .: "sku_id" + <*> o .:? "cover_sticker_id" + <*> o .: "description" + <*> o .:? "banner_asset_id" + +-- | A full sticker object +data Sticker = Sticker + { -- | The sticker's id. + stickerId :: StickerId, + -- | For standard stickers, the id of the pack. + stickerStickerPackId :: Maybe Snowflake, + -- | The sticker's name. + stickerName :: T.Text, + -- | The sticker's description. + stickerDescription :: Maybe T.Text, + -- | Autocomplete/suggestion tags for the sticker (max 200 characters total). + stickerTags :: [T.Text], + -- | Whether the sticker is standard or guild type. + stickerIsStandardType :: Bool, + -- | The sticker's format type. + stickerFormatType :: StickerFormatType, + -- | Whether this guild sticker can be used. + stickerAvailable :: Maybe Bool, + -- | What guild owns this sticker. + stickerGuildId :: Maybe GuildId, + -- | What user uploaded the guild sticker. + stickerUser :: Maybe User, + -- | A standard sticker's sort order in its pack. + stickerSortValue :: Maybe Integer + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON Sticker where + parseJSON = withObject "Sticker" $ \o -> + Sticker <$> o .: "id" + <*> o .:? "pack_id" + <*> o .: "name" + <*> o .:? "description" + <*> ((o .: "tags") <&> T.splitOn "\n") + <*> ((o .: "type") <&> (== (1 :: Int))) + <*> o .: "format_type" + <*> o .:? "available" + <*> o .:? "guild_id" + <*> o .:? "user" + <*> o .:? "sort_value" + +-- | A simplified sticker object. +data StickerItem = StickerItem + { -- | The sticker's id. + stickerItemId :: StickerId, + -- | The sticker's name. + stickerItemName :: T.Text, + -- | The sticker's format type. + stickerItemFormatType :: StickerFormatType + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON StickerItem where + parseJSON = withObject "StickerItem" $ \o -> + StickerItem <$> o .: "id" + <*> o .: "name" + <*> o .: "format_type" + +instance ToJSON StickerItem where + toJSON StickerItem {..} = + object + [ ("id", toJSON stickerItemId), + ("name", toJSON stickerItemName), + ("format_type", toJSON stickerItemFormatType) + ] + +-- | The format of a sticker +data StickerFormatType + = StickerFormatTypePNG + | StickerFormatTypeAPNG + | StickerFormatTypeLOTTIE + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum StickerFormatType where + discordTypeStartValue = StickerFormatTypePNG + fromDiscordType StickerFormatTypePNG = 1 + fromDiscordType StickerFormatTypeAPNG = 2 + fromDiscordType StickerFormatTypeLOTTIE = 3 + +instance ToJSON StickerFormatType where + toJSON = toJSON . fromDiscordType + +instance FromJSON StickerFormatType where + parseJSON = discordTypeParseJSON "StickerFormatType" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Events.hs b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs new file mode 100644 index 0000000..d77cc96 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Events.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Data structures pertaining to gateway dispatch 'Event's +module Discord.Internal.Types.Events where + +import Prelude hiding (id) + +import Data.Time.ISO8601 (parseISO8601) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Network.Socket (HostName) + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Text as T + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Guild +import Discord.Internal.Types.User (User, GuildMember) +import Discord.Internal.Types.Interactions (Interaction) +import Discord.Internal.Types.Emoji (Emoji) +import Discord.Internal.Types.ScheduledEvents (ScheduledEvent) + + +-- | Represents possible events sent by discord. Detailed information can be found at <https://discord.com/developers/docs/topics/gateway>. +data Event = + -- | Contains the initial state information + Ready Int User [GuildUnavailable] T.Text HostName (Maybe Shard) PartialApplication + -- | Response to a @Resume@ gateway command + | Resumed [T.Text] + -- | new guild channel created + | ChannelCreate Channel + -- | channel was updated + | ChannelUpdate Channel + -- | channel was deleted + | ChannelDelete Channel + -- | thread created, also sent when being added to a private thread + | ThreadCreate Channel + -- | thread was updated + | ThreadUpdate Channel + -- | thread was deleted + | ThreadDelete Channel + -- | sent when gaining access to a channel, contains all active threads in that channel + | ThreadListSync ThreadListSyncFields + -- | thread member for the current user was updated + | ThreadMembersUpdate ThreadMembersUpdateFields + -- | message was pinned or unpinned + | ChannelPinsUpdate ChannelId (Maybe UTCTime) + -- | lazy-load for unavailable guild, guild became available, or user joined a new guild + | GuildCreate Guild GuildCreateData + -- | guild was updated + | GuildUpdate Guild + -- | guild became unavailable, or user left/was removed from a guild + | GuildDelete GuildUnavailable + -- | user was banned from a guild + | GuildBanAdd GuildId User + -- | user was unbanned from a guild + | GuildBanRemove GuildId User + -- | guild emojis were updated + | GuildEmojiUpdate GuildId [Emoji] + -- | guild integration was updated + | GuildIntegrationsUpdate GuildId + -- | new user joined a guild + | GuildMemberAdd GuildId GuildMember + -- | user was removed from a guild + | GuildMemberRemove GuildId User + -- | guild member was updated + | GuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + -- | response to @Request Guild Members@ gateway command + | GuildMemberChunk GuildId [GuildMember] + -- | guild role was created + | GuildRoleCreate GuildId Role + -- | guild role was updated + | GuildRoleUpdate GuildId Role + -- | guild role was deleted + | GuildRoleDelete GuildId RoleId + -- | message was created + | MessageCreate Message + -- | message was updated + | MessageUpdate ChannelId MessageId + -- | message was deleted + | MessageDelete ChannelId MessageId + -- | multiple messages were deleted at once + | MessageDeleteBulk ChannelId [MessageId] + -- | user reacted to a message + | MessageReactionAdd ReactionInfo + -- | user removed a reaction from a message + | MessageReactionRemove ReactionInfo + -- | all reactions were explicitly removed from a message + | MessageReactionRemoveAll ChannelId MessageId + -- | all reactions for a given emoji were explicitly removed from a message + | MessageReactionRemoveEmoji ReactionRemoveInfo + -- | user was updated + | PresenceUpdate PresenceInfo + -- | user started typing in a channel + | TypingStart TypingInfo + -- | properties about the user changed + | UserUpdate User + -- | someone joined, left, or moved a voice channel + | InteractionCreate Interaction + -- | VoiceStateUpdate + -- | VoiceServerUpdate + -- | An Unknown Event, none of the others + | UnknownEvent T.Text Object + deriving (Show, Eq) + +-- | Internal Event representation. Each matches to the corresponding constructor of `Event`. +-- +-- An application should never have to use those directly +data EventInternalParse = + InternalReady Int User [GuildUnavailable] T.Text HostName (Maybe Shard) PartialApplication + | InternalResumed [T.Text] + | InternalChannelCreate Channel + | InternalChannelUpdate Channel + | InternalChannelDelete Channel + | InternalThreadCreate Channel + | InternalThreadUpdate Channel + | InternalThreadDelete Channel + | InternalThreadListSync ThreadListSyncFields + | InternalThreadMembersUpdate ThreadMembersUpdateFields + | InternalChannelPinsUpdate ChannelId (Maybe UTCTime) + | InternalGuildCreate Guild GuildCreateData + | InternalGuildUpdate Guild + | InternalGuildDelete GuildUnavailable + | InternalGuildBanAdd GuildId User + | InternalGuildBanRemove GuildId User + | InternalGuildEmojiUpdate GuildId [Emoji] + | InternalGuildIntegrationsUpdate GuildId + | InternalGuildMemberAdd GuildId GuildMember + | InternalGuildMemberRemove GuildId User + | InternalGuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + | InternalGuildMemberChunk GuildId [GuildMember] + | InternalGuildRoleCreate GuildId Role + | InternalGuildRoleUpdate GuildId Role + | InternalGuildRoleDelete GuildId RoleId + | InternalMessageCreate Message + | InternalMessageUpdate ChannelId MessageId + | InternalMessageDelete ChannelId MessageId + | InternalMessageDeleteBulk ChannelId [MessageId] + | InternalMessageReactionAdd ReactionInfo + | InternalMessageReactionRemove ReactionInfo + | InternalMessageReactionRemoveAll ChannelId MessageId + | InternalMessageReactionRemoveEmoji ReactionRemoveInfo + | InternalPresenceUpdate PresenceInfo + | InternalTypingStart TypingInfo + | InternalUserUpdate User + | InternalInteractionCreate Interaction + -- | InternalVoiceStateUpdate + -- | InternalVoiceServerUpdate + | InternalUnknownEvent T.Text Object + deriving (Show, Eq, Read) + +-- | Structure containing partial information about an Application +data PartialApplication = PartialApplication + { partialApplicationID :: ApplicationId + , partialApplicationFlags :: Int + } deriving (Show, Eq, Read) + +instance FromJSON PartialApplication where + parseJSON = withObject "PartialApplication" (\v -> PartialApplication <$> v .: "id" <*> v .: "flags") + +data GuildCreateData = GuildCreateData + { guildCreateJoinedAt :: !UTCTime + , guildCreateLarge :: !Bool + , guildCreateUnavailable :: !(Maybe Bool) + , guildCreateMemberCount :: !Int + -- , guildCreateVoiceStates + , guildCreateMembers :: ![GuildMember] + , guildCreateChannels :: ![Channel] + , guildCreateThreads :: ![Channel] + , guildCreatePresences :: ![PresenceInfo] + -- , guildStageInstances :: [StageI] + , guildCreateScheduledEvents :: ![ScheduledEvent] + } deriving (Show, Eq, Read) + +instance FromJSON GuildCreateData where + parseJSON = withObject "GuildCreateData" $ \o -> + GuildCreateData <$> o .: "joined_at" + <*> o .: "large" + <*> o .:? "unavailable" + <*> o .: "member_count" + <*> o .: "members" + <*> o .: "channels" + <*> o .: "threads" + <*> o .: "presences" + <*> o .: "guild_scheduled_events" + +-- | Structure containing information about a reaction +data ReactionInfo = ReactionInfo + { reactionUserId :: UserId -- ^ User who reacted + , reactionGuildId :: Maybe GuildId -- ^ Guild in which the reacted message is (if any) + , reactionChannelId :: ChannelId -- ^ Channel in which the reacted message is + , reactionMessageId :: MessageId -- ^ The reacted message + , reactionEmoji :: Emoji -- ^ The Emoji used for the reaction + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ReactionInfo where + parseJSON = withObject "ReactionInfo" $ \o -> + ReactionInfo <$> o .: "user_id" + <*> o .:? "guild_id" + <*> o .: "channel_id" + <*> o .: "message_id" + <*> o .: "emoji" + +-- | Structure containing information about a reaction that has been removed +data ReactionRemoveInfo = ReactionRemoveInfo + { reactionRemoveChannelId :: ChannelId + , reactionRemoveGuildId :: GuildId + , reactionRemoveMessageId :: MessageId + , reactionRemoveEmoji :: Emoji + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ReactionRemoveInfo where + parseJSON = withObject "ReactionRemoveInfo" $ \o -> + ReactionRemoveInfo <$> o .: "guild_id" + <*> o .: "channel_id" + <*> o .: "message_id" + <*> o .: "emoji" + +-- | Structre containing typing status information +data TypingInfo = TypingInfo + { typingUserId :: UserId + , typingChannelId :: ChannelId + , typingTimestamp :: UTCTime + } deriving (Show, Read, Eq, Ord) + +instance FromJSON TypingInfo where + parseJSON = withObject "TypingInfo" $ \o -> + do cid <- o .: "channel_id" + uid <- o .: "user_id" + posix <- o .: "timestamp" + let utc = posixSecondsToUTCTime posix + pure (TypingInfo uid cid utc) + + + +-- | Convert ToJSON value to FromJSON value +reparse :: (ToJSON a, FromJSON b) => a -> Parser b +reparse val = case parseEither parseJSON $ toJSON val of + Left r -> fail r + Right b -> pure b + +-- | Remove the "wss://" and the trailing slash in a gateway URL, thereby returning +-- the hostname portion of the URL that we can connect to. +extractHostname :: String -> HostName +extractHostname ('w':'s':'s':':':'/':'/':rest) = extractHostname rest +extractHostname "/" = [] +extractHostname (a:b) = a:extractHostname b +extractHostname [] = [] + +-- | Parse an event from name and JSON data +eventParse :: T.Text -> Object -> Parser EventInternalParse +eventParse t o = case t of + "READY" -> InternalReady <$> o .: "v" + <*> o .: "user" + <*> o .: "guilds" + <*> o .: "session_id" + -- Discord can send us the resume gateway URL prefixed with "wss://", + -- and suffixed with a trailing slash. This is not a valid HostName, + -- so remove them both if they exist. + <*> (extractHostname <$> o .: "resume_gateway_url") + <*> o .: "shard" + <*> o .: "application" + "RESUMED" -> InternalResumed <$> o .: "_trace" + "CHANNEL_CREATE" -> InternalChannelCreate <$> reparse o + "CHANNEL_UPDATE" -> InternalChannelUpdate <$> reparse o + "CHANNEL_DELETE" -> InternalChannelDelete <$> reparse o + "THREAD_CREATE" -> InternalThreadCreate <$> reparse o + "THREAD_UPDATE" -> InternalThreadUpdate <$> reparse o + "THREAD_DELETE" -> InternalThreadDelete <$> reparse o + "THREAD_LIST_SYNC" -> InternalThreadListSync <$> reparse o + "THREAD_MEMBERS_UPDATE" -> InternalThreadMembersUpdate <$> reparse o + "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" + stamp <- o .:? "last_pin_timestamp" + let utc = stamp >>= parseISO8601 + pure (InternalChannelPinsUpdate id utc) + "GUILD_CREATE" -> InternalGuildCreate <$> reparse o <*> reparse o + "GUILD_UPDATE" -> InternalGuildUpdate <$> reparse o + "GUILD_DELETE" -> InternalGuildDelete <$> reparse o + "GUILD_BAN_ADD" -> InternalGuildBanAdd <$> o .: "guild_id" <*> o .: "user" + "GUILD_BAN_REMOVE" -> InternalGuildBanRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_EMOJI_UPDATE" -> InternalGuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" + "GUILD_INTEGRATIONS_UPDATE" -> InternalGuildIntegrationsUpdate <$> o .: "guild_id" + "GUILD_MEMBER_ADD" -> InternalGuildMemberAdd <$> o .: "guild_id" <*> reparse o + "GUILD_MEMBER_REMOVE" -> InternalGuildMemberRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_MEMBER_UPDATE" -> InternalGuildMemberUpdate <$> o .: "guild_id" + <*> o .: "roles" + <*> o .: "user" + <*> o .:? "nick" + "GUILD_MEMBERS_CHUNK" -> InternalGuildMemberChunk <$> o .: "guild_id" <*> o .: "members" + "GUILD_ROLE_CREATE" -> InternalGuildRoleCreate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_UPDATE" -> InternalGuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_DELETE" -> InternalGuildRoleDelete <$> o .: "guild_id" <*> o .: "role_id" + "MESSAGE_CREATE" -> InternalMessageCreate <$> reparse o + "MESSAGE_UPDATE" -> InternalMessageUpdate <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE" -> InternalMessageDelete <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE_BULK" -> InternalMessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" + "MESSAGE_REACTION_ADD" -> InternalMessageReactionAdd <$> reparse o + "MESSAGE_REACTION_REMOVE" -> InternalMessageReactionRemove <$> reparse o + "MESSAGE_REACTION_REMOVE_ALL" -> InternalMessageReactionRemoveAll <$> o .: "channel_id" + <*> o .: "message_id" + "MESSAGE_REACTION_REMOVE_EMOJI" -> InternalMessageReactionRemoveEmoji <$> reparse o + "PRESENCE_UPDATE" -> InternalPresenceUpdate <$> reparse o + "TYPING_START" -> InternalTypingStart <$> reparse o + "USER_UPDATE" -> InternalUserUpdate <$> reparse o + -- "VOICE_STATE_UPDATE" -> InternalVoiceStateUpdate <$> reparse o + -- "VOICE_SERVER_UPDATE" -> InternalVoiceServerUpdate <$> reparse o + "INTERACTION_CREATE" -> InternalInteractionCreate <$> reparse o + _other_event -> InternalUnknownEvent t <$> reparse o diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs new file mode 100644 index 0000000..a3b8f90 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Gateway.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures needed for interfacing with the Websocket +-- Gateway +module Discord.Internal.Types.Gateway where + +import System.Info + +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Aeson +import Data.Aeson.Types +import Data.Default (Default, def) +import Data.Maybe (fromMaybe) +import Data.Functor +import Text.Read (readMaybe) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Events +import Discord.Internal.Types.Guild (Activity (..)) + +-- | Messages that can be sent by gateway to the library +data GatewayReceivable + = Dispatch EventInternalParse Integer + | HeartbeatRequest Integer + | Reconnect + | InvalidSession Bool + | Hello Integer + | HeartbeatAck + | ParseError T.Text + deriving (Show, Eq, Read) + +-- | Sent to gateway by our library +data GatewaySendableInternal + = Heartbeat Integer + | Identify Auth GatewayIntent (Int, Int) + | Resume Auth T.Text Integer + deriving (Show, Read, Eq, Ord) + + +-- | Gateway intents to subrscribe to +-- +-- Details of which intent englobs what data is avalilable at +-- [the official Discord documentation](https://discord.com/developers/docs/topics/gateway#list-of-intents) +data GatewayIntent = GatewayIntent + { gatewayIntentGuilds :: Bool + , gatewayIntentMembers :: Bool + , gatewayIntentBans :: Bool + , gatewayIntentEmojis :: Bool + , gatewayIntentIntegrations :: Bool + , gatewayIntentWebhooks :: Bool + , gatewayIntentInvites :: Bool + , gatewayIntentVoiceStates :: Bool + , gatewayIntentPresences :: Bool + , gatewayIntentMessageChanges :: Bool + , gatewayIntentMessageReactions :: Bool + , gatewayIntentMessageTyping :: Bool + , gatewayIntentDirectMessageChanges :: Bool + , gatewayIntentDirectMessageReactions :: Bool + , gatewayIntentDirectMessageTyping :: Bool + , gatewayIntentMessageContent :: Bool + } deriving (Show, Read, Eq, Ord) + +instance Default GatewayIntent where + def = GatewayIntent { gatewayIntentGuilds = True + , gatewayIntentMembers = False -- false + , gatewayIntentBans = True + , gatewayIntentEmojis = True + , gatewayIntentIntegrations = True + , gatewayIntentWebhooks = True + , gatewayIntentInvites = True + , gatewayIntentVoiceStates = True + , gatewayIntentPresences = False -- false + , gatewayIntentMessageChanges = True + , gatewayIntentMessageReactions = True + , gatewayIntentMessageTyping = True + , gatewayIntentDirectMessageChanges = True + , gatewayIntentDirectMessageReactions = True + , gatewayIntentDirectMessageTyping = True + , gatewayIntentMessageContent = True + } + +compileGatewayIntent :: GatewayIntent -> Int +compileGatewayIntent GatewayIntent{..} = + sum $ [ if on then flag else 0 + | (flag, on) <- [ ( 1, gatewayIntentGuilds) + , (2 ^ 1, gatewayIntentMembers) + , (2 ^ 2, gatewayIntentBans) + , (2 ^ 3, gatewayIntentEmojis) + , (2 ^ 4, gatewayIntentIntegrations) + , (2 ^ 5, gatewayIntentWebhooks) + , (2 ^ 6, gatewayIntentInvites) + , (2 ^ 7, gatewayIntentVoiceStates) + , (2 ^ 8, gatewayIntentPresences) + , (2 ^ 9, gatewayIntentMessageChanges) + , (2 ^ 10, gatewayIntentMessageReactions) + , (2 ^ 11, gatewayIntentMessageTyping) + , (2 ^ 12, gatewayIntentDirectMessageChanges) + , (2 ^ 13, gatewayIntentDirectMessageReactions) + , (2 ^ 14, gatewayIntentDirectMessageTyping) + , (2 ^ 15, gatewayIntentMessageContent) + ] + ] + +-- | Sent to gateway by a user +data GatewaySendable + = RequestGuildMembers RequestGuildMembersOpts + | UpdateStatus UpdateStatusOpts + | UpdateStatusVoice UpdateStatusVoiceOpts + deriving (Show, Read, Eq, Ord) + +-- | Options for `RequestGuildMembers` +data RequestGuildMembersOpts = RequestGuildMembersOpts + { requestGuildMembersOptsGuildId :: GuildId + , requestGuildMembersOptsNamesStartingWith :: T.Text + , requestGuildMembersOptsLimit :: Integer } + deriving (Show, Read, Eq, Ord) + +-- | Options for `UpdateStatusVoice` +data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts + { updateStatusVoiceOptsGuildId :: GuildId + , updateStatusVoiceOptsChannelId :: Maybe ChannelId + , updateStatusVoiceOptsIsMuted :: Bool + , updateStatusVoiceOptsIsDeaf :: Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Options for `UpdateStatus` +data UpdateStatusOpts = UpdateStatusOpts + { updateStatusOptsSince :: Maybe UTCTime + , updateStatusOptsGame :: Maybe Activity + , updateStatusOptsNewStatus :: UpdateStatusType + , updateStatusOptsAFK :: Bool + } + deriving (Show, Read, Eq, Ord) + +-- | Possible values for `updateStatusOptsNewStatus` +data UpdateStatusType = UpdateStatusOnline + | UpdateStatusDoNotDisturb + | UpdateStatusAwayFromKeyboard + | UpdateStatusInvisibleOffline + | UpdateStatusOffline + deriving (Show, Read, Eq, Ord, Enum) + + +-- | Converts an UpdateStatusType to a textual representation +statusString :: UpdateStatusType -> T.Text +statusString s = case s of + UpdateStatusOnline -> "online" + UpdateStatusDoNotDisturb -> "dnd" + UpdateStatusAwayFromKeyboard -> "idle" + UpdateStatusInvisibleOffline -> "invisible" + UpdateStatusOffline -> "offline" + +instance FromJSON GatewayReceivable where + parseJSON = withObject "payload" $ \o -> do + op <- o .: "op" :: Parser Int + case op of + 0 -> do etype <- o .: "t" + ejson <- o .: "d" + case ejson of + Object hm -> Dispatch <$> eventParse etype hm <*> o .: "s" + _other -> Dispatch (InternalUnknownEvent "Dispatch payload wasn't an object" o) + <$> o .: "s" + 1 -> HeartbeatRequest . fromMaybe 0 . readMaybe <$> o .: "d" + 7 -> pure Reconnect + 9 -> InvalidSession <$> o .: "d" + 10 -> do od <- o .: "d" + int <- od .: "heartbeat_interval" + pure (Hello int) + 11 -> pure HeartbeatAck + _ -> fail ("Unknown Receivable payload ID:" <> show op) + +-- instance FromJSON GatewaySendable where +-- parseJSON = withObject "payload" $ \o -> do +-- op <- o .: "op" :: Parser Int +-- case op of +-- 1 -> Heartbeat . fromMaybe 0 . readMaybe <$> o .: "d" +-- 2 -> do od <- o .: "d" +-- tok <- od .: "token" +-- compress <- od .:? "compress" .!= False +-- +-- _ -> fail ("Unknown Sendable payload ID:" <> show op) + +instance ToJSON GatewaySendableInternal where + toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ] + toJSON (Identify token intent shard) = object [ + "op" .= (2 :: Int) + , "d" .= object [ + "token" .= authToken token + , "intents" .= compileGatewayIntent intent + , "properties" .= object [ + "$os" .= os + , "$browser" .= ("discord-haskell" :: T.Text) + , "$device" .= ("discord-haskell" :: T.Text) + , "$referrer" .= ("" :: T.Text) + , "$referring_domain" .= ("" :: T.Text) + ] + , "compress" .= False + , "large_threshold" .= (50 :: Int) -- stop sending offline members over 50 + , "shard" .= shard + ] + ] + toJSON (Resume token session seqId) = object [ + "op" .= (6 :: Int) + , "d" .= object [ + "token" .= authToken token + , "session_id" .= session + , "seq" .= seqId + ] + ] + +instance ToJSON GatewaySendable where + toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [ + "op" .= (3 :: Int) + , "d" .= object [ + "since" .= (since <&> \s -> 1000 * utcTimeToPOSIXSeconds s) -- takes UTCTime and returns unix time (in milliseconds) + , "afk" .= afk + , "status" .= statusString status + , "game" .= (game <&> \a -> object [ + "name" .= activityName a + , "type" .= fromDiscordType (activityType a) + , "url" .= activityUrl a + ]) + ] + ] + toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) = + object [ + "op" .= (4 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "channel_id" .= channel + , "self_mute" .= mute + , "self_deaf" .= deaf + ] + ] + toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) = + object [ + "op" .= (8 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "query" .= query + , "limit" .= limit + ] + ] diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs new file mode 100644 index 0000000..5bddfaf --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Guild.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Types relating to Discord Guilds (servers) +module Discord.Internal.Types.Guild where + +import Data.Time.Clock + +import Data.Aeson +import qualified Data.Text as T +import Data.Data (Data) +import Data.Default (Default(..)) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Color (DiscordColor) +import Discord.Internal.Types.User (User) +import Discord.Internal.Types.Emoji (Emoji, StickerItem) +import Data.List + +-- | Guilds in Discord represent a collection of users and channels into an isolated +-- "Server" +-- +-- https://discord.com/developers/docs/resources/guild#guild-object +data Guild = Guild + { guildId :: GuildId -- ^ Guild id + , guildName :: T.Text -- ^ Guild name (2 - 100 chars) + , guildIcon :: Maybe T.Text -- ^ Icon hash + , guildIconHash :: Maybe T.Text -- ^ Icon hash, when returned in template object + , guildSplash :: Maybe T.Text -- ^ Splash hash + , guildDiscoverySplash :: Maybe T.Text -- ^ Discovery splash hash + , guildOwner :: Maybe Bool -- ^ True is user is the owner of the guild + , guildOwnerId :: UserId -- ^ Guild owner id + , guildPermissions :: Maybe T.Text -- ^ Total permissions for the user in the guild + , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel + , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds + , guildWidgetEnabled :: Maybe Bool -- ^ Id of embedded channel + , guildWidgetChannelId :: Maybe ChannelId -- ^ Id of embedded channel + , guildVerificationLevel :: Integer -- ^ Level of verification + , guildNotification :: Integer -- ^ Level of default notifications + , guildExplicitFilterLevel :: Integer -- ^ Whose media gets scanned + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + , guildFeatures :: [T.Text] -- ^ Array of guild feature strings + , guildMultiFactAuth :: !Integer -- ^ MFA level for the guild + , guildApplicationId :: Maybe ApplicationId -- ^ Application id of the guild if bot created + , guildSystemChannelId :: Maybe ChannelId -- ^ Channel where guild notices such as welcome messages and boost events + , guildSystemChannelFlags :: Integer -- ^ Flags on the system channel + , guildRulesChannelId :: Maybe ChannelId -- ^ Id of channel with rules/guidelines + , guildMaxPresences :: Maybe Integer -- ^ Maximum number of prescences in the guild + , guildMaxMembers :: Maybe Integer -- ^ Maximum number of members in the guild + , guildVanityURL :: Maybe T.Text -- ^ Vanity url code for the guild + , guildDescription :: Maybe T.Text -- ^ Description of a commmunity guild + , guildBanner :: Maybe T.Text -- ^ Banner hash + , guildPremiumTier :: Integer -- ^ Premium tier (boost level) + , guildSubscriptionCount :: Maybe Integer -- ^ Number of boosts the guild has + , guildPreferredLocale :: T.Text -- ^ Preferred locale of a community server + , guildPublicUpdatesChannel :: Maybe ChannelId -- ^ Id of channel where admins and mods get updates + , guildMaxVideoUsers :: Maybe Integer -- ^ Maximum number of users in video channel + , guildApproxMemberCount :: Maybe Integer -- ^ Approximate number of members in the guild (GET /guilds/<id> endpoint when with_counts is true) + , guildApproxPresenceCount :: Maybe Integer -- ^ Approximate number of non-offline members in the guild (GET /guilds/<id> endpoint when with_counts is true) + -- welcome_screen + , guildNSFWLevel :: Integer -- ^ Guild NSFW level + -- stage_instances + , guildStickers :: Maybe [StickerItem] -- ^ Custom guild stickers + -- guild_scheduled_events + , guildPremiumBar :: Bool -- ^ Whether the guild has the boost progress bar enabled + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Guild where + parseJSON = withObject "Guild" $ \o -> + Guild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "icon_hash" + <*> o .:? "splash" + <*> o .:? "discovery_splash" + <*> o .:? "owner" + <*> o .: "owner_id" + <*> o .:? "permissions" + <*> o .:? "afk_channel_id" + <*> o .: "afk_timeout" + <*> o .:? "widget_enabled" + <*> o .:? "widget_channel_id" + <*> o .: "verification_level" + <*> o .: "default_message_notifications" + <*> o .: "explicit_content_filter" + <*> o .: "roles" + <*> o .: "emojis" + <*> o .: "features" + <*> o .: "mfa_level" + <*> o .:? "application_id" + <*> o .:? "system_channel_id" + <*> o .: "system_channel_flags" + <*> o .:? "rules_channel_id" + <*> o .:? "max_presences" + <*> o .:? "max_members" + <*> o .:? "vanity_url_code" + <*> o .:? "description" + <*> o .:? "banner" + <*> o .: "premium_tier" + <*> o .:? "premium_subscription_count" + <*> o .: "preferred_locale" + <*> o .:? "public_updates_channel_id" + <*> o .:? "max_video_channel_users" + <*> o .:? "approximate_member_count" + <*> o .:? "approximate_presence_count" + -- welcome_screen + <*> o .: "nsfw_level" + -- stage_instances + <*> o .:? "stickers" + <*> o .: "premium_progress_bar_enabled" + +newtype GuildUnavailable = GuildUnavailable + { idOnceAvailable :: GuildId + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildUnavailable where + parseJSON = withObject "GuildUnavailable" $ \o -> + GuildUnavailable <$> o .: "id" + +data PresenceInfo = PresenceInfo + { presenceUserId :: UserId + -- , presenceRoles :: [RoleId] + , presenceActivities :: Maybe [Activity] + , presenceGuildId :: Maybe GuildId + , presenceStatus :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON PresenceInfo where + parseJSON = withObject "PresenceInfo" $ \o -> + PresenceInfo <$> (o .: "user" >>= (.: "id")) + <*> o .: "activities" + <*> o .:? "guild_id" + <*> o .: "status" + +-- | Object for a single activity +-- +-- https://discord.com/developers/docs/topics/gateway#activity-object +-- +-- When setting a bot's activity, only the name, url, and type are sent - and +-- it seems that not many types are permitted either. +data Activity = + Activity + { activityName :: T.Text -- ^ Name of activity + , activityType :: ActivityType -- ^ Type of activity + , activityUrl :: Maybe T.Text -- ^ URL of the activity (only verified when streaming) + , activityCreatedAt :: Integer -- ^ unix time in milliseconds + , activityTimeStamps :: Maybe ActivityTimestamps -- ^ Start and end times + , activityApplicationId :: Maybe ApplicationId -- ^ Application of the activity + , activityDetails :: Maybe T.Text -- ^ Details of Activity + , activityState :: Maybe T.Text -- ^ State of the user's party + , activityEmoji :: Maybe Emoji -- ^ Simplified emoji object + , activityParty :: Maybe ActivityParty -- ^ Info for the current player's party + -- assets + -- secrets + , activityInstance :: Maybe Bool -- ^ Whether or not the activity is an instanced game session + , activityFlags :: Maybe Integer -- ^ The flags https://discord.com/developers/docs/topics/gateway#activity-object-activity-flags + , activityButtons :: Maybe [ActivityButton] -- ^ Custom buttons shown in Rich Presence + } + deriving (Show, Read, Eq, Ord) + +instance Default Activity where + def = Activity "discord-haskell" ActivityTypeGame Nothing 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromJSON Activity where + parseJSON = withObject "Activity" $ \o -> do + Activity <$> o .: "name" + <*> o .: "type" + <*> o .:? "url" + <*> o .: "created_at" + <*> o .:? "timestamps" + <*> o .:? "application_id" + <*> o .:? "details" + <*> o .:? "state" + <*> o .:? "emoji" + <*> o .:? "party" + -- assets + -- secrets + <*> o .:? "instance" + <*> o .:? "flags" + <*> o .:? "buttons" + +data ActivityTimestamps = ActivityTimestamps + { activityTimestampsStart :: Maybe Integer -- ^ unix time in milliseconds + , activityTimestampsEnd :: Maybe Integer -- ^ unix time in milliseconds + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityTimestamps where + parseJSON = withObject "ActivityTimestamps" $ \o -> + ActivityTimestamps <$> o .:? "start" + <*> o .:? "end" + +data ActivityParty = ActivityParty + { activityPartyId :: Maybe T.Text + , activityPartySize :: Maybe (Integer, Integer) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityParty where + parseJSON = withObject "ActivityParty" $ \o -> + ActivityParty <$> o .:? "id" + <*> o .:? "size" + +data ActivityButton = ActivityButton + { activityButtonLabel :: T.Text + , activityButtonUrl :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ActivityButton where + parseJSON = withObject "ActivityButton" $ \o -> + ActivityButton <$> o .: "label" + <*> o .: "url" + +-- | To see what these look like, go to here: +-- https://discord.com/developers/docs/topics/gateway#activity-object-activity-types +data ActivityType = + ActivityTypeGame + | ActivityTypeStreaming + | ActivityTypeListening + | ActivityTypeWatching + | ActivityTypeCustom + | ActivityTypeCompeting + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ActivityType where + discordTypeStartValue = ActivityTypeGame + fromDiscordType ActivityTypeGame = 0 + fromDiscordType ActivityTypeStreaming = 1 + fromDiscordType ActivityTypeListening = 2 + fromDiscordType ActivityTypeWatching = 3 + fromDiscordType ActivityTypeCustom = 4 + fromDiscordType ActivityTypeCompeting = 5 + +instance FromJSON ActivityType where + parseJSON = discordTypeParseJSON "ActivityType" + +data PartialGuild = PartialGuild + { partialGuildId :: GuildId + , partialGuildName :: T.Text + , partialGuildIcon :: Maybe T.Text + , partialGuildOwner :: Bool + , partialGuildPermissions :: T.Text + } deriving (Show, Read, Eq, Ord) + +instance FromJSON PartialGuild where + parseJSON = withObject "PartialGuild" $ \o -> + PartialGuild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "owner" .!= False + <*> o .: "permissions" + + +-- | Roles represent a set of permissions attached to a group of users. Roles have unique +-- names, colors, and can be "pinned" to the side bar, causing their members to be listed separately. +-- Roles are unique per guild, and can have separate permission profiles for the global context +-- (guild) and channel context. +data Role = + Role { + roleId :: RoleId -- ^ The role id + , roleName :: T.Text -- ^ The role name + , roleColor :: DiscordColor -- ^ Integer representation of color code + , roleHoist :: Bool -- ^ If the role is pinned in the user listing + , rolePos :: Integer -- ^ Position of this role + , rolePerms :: RolePermissions -- ^ Permission bit set + , roleManaged :: Bool -- ^ Whether this role is managed by an integration + , roleMention :: Bool -- ^ Whether this role is mentionable + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Role where + parseJSON = withObject "Role" $ \o -> + Role <$> o .: "id" + <*> o .: "name" + <*> o .: "color" + <*> o .: "hoist" + <*> o .: "position" + <*> o .: "permissions" + <*> o .: "managed" + <*> o .: "mentionable" + + +-- | If there is no such role on the guild return nothing +-- otherwise return the role. Take the head of the list. List should always be one, because the ID is unique +roleIdToRole :: Guild -> RoleId -> Maybe Role +roleIdToRole g r = find(\x -> roleId x == r) $ guildRoles g + + +-- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added +data VoiceRegion = VoiceRegion + { voiceRegionId :: T.Text -- ^ Unique id of the region + , voiceRegionName :: T.Text -- ^ Name of the region + , voiceRegionVip :: Bool -- ^ True if this is a VIP only server + , voiceRegionOptimal :: Bool -- ^ True for the closest server to a client + , voiceRegionDeprecated :: Bool -- ^ Whether this is a deprecated region + , voiceRegionCustom :: Bool -- ^ Whether this is a custom region + } deriving (Show, Read, Eq, Ord) + +instance FromJSON VoiceRegion where + parseJSON = withObject "VoiceRegion" $ \o -> + VoiceRegion <$> o .: "id" + <*> o .: "name" + <*> o .: "vip" + <*> o .: "optimal" + <*> o .: "deprecated" + <*> o .: "custom" + +-- | Info about a Ban +data GuildBan = GuildBan + { guildBanReason :: T.Text + , guildBanUser :: User + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildBan where + parseJSON = withObject "GuildBan" $ \o -> GuildBan <$> o .: "reason" <*> o .: "user" + +-- | Represents a code to add a user to a guild +data Invite = Invite + { inviteCode :: T.Text -- ^ The invite code + , inviteGuildId :: Maybe GuildId -- ^ The guild the code will invite to + , inviteChannelId :: ChannelId -- ^ The channel the code will invite to + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Invite where + parseJSON = withObject "Invite" $ \o -> + Invite <$> o .: "code" + <*> (do g <- o .:? "guild" + case g of Just g2 -> g2 .: "id" + Nothing -> pure Nothing) + <*> ((o .: "channel") >>= (.: "id")) + +-- | Invite code with additional metadata +data InviteWithMeta = InviteWithMeta Invite InviteMeta + +instance FromJSON InviteWithMeta where + parseJSON ob = InviteWithMeta <$> parseJSON ob <*> parseJSON ob + +-- | Additional metadata about an invite. +data InviteMeta = InviteMeta + { inviteCreator :: User -- ^ The user that created the invite + , inviteUses :: Integer -- ^ Number of times the invite has been used + , inviteMax :: Integer -- ^ Max number of times the invite can be used + , inviteAge :: Integer -- ^ The duration (in seconds) after which the invite expires + , inviteTemp :: Bool -- ^ Whether this invite only grants temporary membership + , inviteCreated :: UTCTime -- ^ When the invite was created + , inviteRevoked :: Bool -- ^ If the invite is revoked + } deriving (Show, Read, Eq, Ord) + +instance FromJSON InviteMeta where + parseJSON = withObject "InviteMeta" $ \o -> + InviteMeta <$> o .: "inviter" + <*> o .: "uses" + <*> o .: "max_uses" + <*> o .: "max_age" + <*> o .: "temporary" + <*> o .: "created_at" + <*> o .: "revoked" + +-- | Represents the behavior of a third party account link. +data Integration = Integration + { integrationId :: !Snowflake -- ^ Integration id + , integrationName :: T.Text -- ^ Integration name + , integrationType :: T.Text -- ^ Integration type (Twitch, Youtube, ect.) + , integrationEnabled :: Bool -- ^ Is the integration enabled + , integrationSyncing :: Bool -- ^ Is the integration syncing + , integrationRole :: RoleId -- ^ Id the integration uses for "subscribers" + , integrationBehavior :: Integer -- ^ The behavior of expiring subscribers + , integrationGrace :: Integer -- ^ The grace period before expiring subscribers + , integrationOwner :: User -- ^ The user of the integration + , integrationAccount :: IntegrationAccount -- ^ The account the integration links to + , integrationSync :: UTCTime -- ^ When the integration was last synced + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Integration where + parseJSON = withObject "Integration" $ \o -> + Integration <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "enabled" + <*> o .: "syncing" + <*> o .: "role_id" + <*> o .: "expire_behavior" + <*> o .: "expire_grace_period" + <*> o .: "user" + <*> o .: "account" + <*> o .: "synced_at" + +-- | Represents a third party account link. +data IntegrationAccount = IntegrationAccount + { accountId :: T.Text -- ^ The id of the account. + , accountName :: T.Text -- ^ The name of the account. + } deriving (Show, Read, Eq, Ord) + +instance FromJSON IntegrationAccount where + parseJSON = withObject "IntegrationAccount" $ \o -> + IntegrationAccount <$> o .: "id" <*> o .: "name" + +-- | Represents an image to be used in third party sites to link to a discord channel +data GuildWidget = GuildWidget + { widgetEnabled :: Bool -- ^ Whether the widget is enabled + , widgetChannelId :: ChannelId -- ^ The widget channel id + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildWidget where + parseJSON = withObject "GuildWidget" $ \o -> + GuildWidget <$> o .: "enabled" <*> o .: "channel_id" + +instance ToJSON GuildWidget where + toJSON (GuildWidget enabled snowflake) = object + [ "enabled" .= enabled + , "channel_id" .= snowflake + ] diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs new file mode 100644 index 0000000..173f908 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Interactions.hs @@ -0,0 +1,665 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Discord.Internal.Types.Interactions + ( Interaction (..), + ComponentData (..), + ApplicationCommandData (..), + OptionsData (..), + OptionDataSubcommandOrGroup (..), + OptionDataSubcommand (..), + OptionDataValue (..), + InteractionToken, + ResolvedData (..), + MemberOrUser (..), + InteractionResponse (..), + interactionResponseBasic, + InteractionResponseAutocomplete (..), + InteractionResponseMessage (..), + interactionResponseMessageBasic, + InteractionResponseMessageFlags (..), + InteractionResponseMessageFlag (..), + InteractionResponseModalData (..), + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Monad (join) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Bits (Bits (shift, (.|.))) +import Data.Foldable (Foldable (toList)) +import qualified Data.Text as T +import Discord.Internal.Types.ApplicationCommands (Choice, Number) +import Discord.Internal.Types.Channel (AllowedMentions, Attachment, Message) +import Discord.Internal.Types.Components (ActionRow, TextInput) +import Discord.Internal.Types.Embed (CreateEmbed, createEmbed) +import Discord.Internal.Types.Prelude (ApplicationCommandId, ApplicationId, ChannelId, GuildId, InteractionId, InteractionToken, MessageId, RoleId, Snowflake, UserId, objectFromMaybes, (.=?)) +import Discord.Internal.Types.User (GuildMember, User) + +-- | An interaction received from discord. +data Interaction + = InteractionComponent + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + componentData :: ComponentData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What message is associated with this interaction. + interactionMessage :: Message, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + | InteractionPing + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text + } + | InteractionApplicationCommand + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + applicationCommandData :: ApplicationCommandData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + | InteractionApplicationCommandAutocomplete + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + applicationCommandData :: ApplicationCommandData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + | InteractionModalSubmit + { -- | The id of this interaction. + interactionId :: InteractionId, + -- | The id of the application that this interaction belongs to. + interactionApplicationId :: ApplicationId, + -- | The data for this interaction. + modalData :: ModalData, + -- | What guild this interaction comes from. + interactionGuildId :: Maybe GuildId, + -- | What channel this interaction comes from. + interactionChannelId :: Maybe ChannelId, + -- | What user/member this interaction comes from. + interactionUser :: MemberOrUser, + -- | The unique token that represents this interaction. + interactionToken :: InteractionToken, + -- | What version of interaction is this (always 1). + interactionVersion :: Int, + -- | What permissions does the app or bot have within the sent channel. + interactionPermissions :: Maybe T.Text, + -- | The invoking user's preferred locale. + interactionLocale :: T.Text, + -- | The invoking guild's preferred locale. + interactionGuildLocale :: Maybe T.Text + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON Interaction where + parseJSON = + withObject + "Interaction" + ( \v -> do + iid <- v .: "id" + aid <- v .: "application_id" + gid <- v .:? "guild_id" + cid <- v .:? "channel_id" + tok <- v .: "token" + version <- v .: "version" + glocale <- v .:? "guild_locale" + permissions <- v .:? "app_permissions" + t <- v .: "type" :: Parser Int + case t of + 1 -> return $ InteractionPing iid aid tok version permissions + 2 -> + InteractionApplicationCommand iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> return permissions + <*> v .: "locale" + <*> return glocale + 3 -> + InteractionComponent iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> v .: "message" + <*> return permissions + <*> v .: "locale" + <*> return glocale + 4 -> + InteractionApplicationCommandAutocomplete iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> return permissions + <*> v .: "locale" + <*> return glocale + 5 -> + InteractionModalSubmit iid aid + <$> v .: "data" + <*> return gid + <*> return cid + <*> parseJSON (Object v) + <*> return tok + <*> return version + <*> return permissions + <*> v .: "locale" + <*> return glocale + _ -> fail "unknown interaction type" + ) + +newtype MemberOrUser = MemberOrUser (Either GuildMember User) + deriving (Show, Read, Eq, Ord) + +instance {-# OVERLAPPING #-} FromJSON MemberOrUser where + parseJSON = + withObject + "MemberOrUser" + ( \v -> MemberOrUser <$> (Left <$> v .: "member" <|> Right <$> v .: "user") + ) + +data ComponentData + = ButtonData + { -- | The unique id of the component (up to 100 characters). + componentDataCustomId :: T.Text + } + | SelectMenuData + { -- | The unique id of the component (up to 100 characters). + componentDataCustomId :: T.Text, + -- | Values for the select menu. + componentDataValues :: SelectMenuData + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ComponentData where + parseJSON = + withObject + "ComponentData" + ( \v -> do + cid <- v .: "custom_id" + t <- v .: "component_type" :: Parser Int + case t of + 2 -> return $ ButtonData cid + _ | t `elem` [3, 5, 6, 7, 8] -> + SelectMenuData cid + <$> parseJSON (toJSON v) + _ -> fail $ "unknown interaction data component type: " <> show t + ) + +data SelectMenuData + = SelectMenuDataText [T.Text] -- ^ The values of text chosen options + | SelectMenuDataUser [UserId] -- ^ The users selected + | SelectMenuDataRole [RoleId] -- ^ The roles selected + | SelectMenuDataMentionable [Snowflake] -- ^ The users or roles selected + | SelectMenuDataChannels [ChannelId] -- ^ The channels selected + deriving (Show, Read, Eq, Ord) + +instance FromJSON SelectMenuData where + parseJSON = + withObject + "SelectMenuData" + $ \v -> do + t <- v .: "component_type" :: Parser Int + let cons :: forall a. FromJSON a => ([a] -> SelectMenuData) -> Parser SelectMenuData + cons f = f <$> v .: "values" + case t of + 3 -> cons SelectMenuDataText + 5 -> cons SelectMenuDataUser + 6 -> cons SelectMenuDataRole + 7 -> cons SelectMenuDataMentionable + 8 -> cons SelectMenuDataChannels + _ -> fail $ "unknown SelectMenuData type: " <> show t + +data ApplicationCommandData + = ApplicationCommandDataUser + { -- | Id of the invoked command. + applicationCommandDataId :: ApplicationCommandId, + -- | Name of the invoked command. + applicationCommandDataName :: T.Text, + -- | The resolved data in the command. + resolvedData :: Maybe ResolvedData, + -- | The id of the user that is the target. + applicationCommandDataTargetUserId :: UserId + } + | ApplicationCommandDataMessage + { -- | Id of the invoked command. + applicationCommandDataId :: ApplicationCommandId, + -- | Name of the invoked command. + applicationCommandDataName :: T.Text, + -- | The resolved data in the command. + resolvedData :: Maybe ResolvedData, + -- | The id of the message that is the target. + applicationCommandDataTargetMessageId :: MessageId + } + | ApplicationCommandDataChatInput + { -- | Id of the invoked command. + applicationCommandDataId :: ApplicationCommandId, + -- | Name of the invoked command. + applicationCommandDataName :: T.Text, + -- | The resolved data in the command. + resolvedData :: Maybe ResolvedData, + -- | The options of the application command. + optionsData :: Maybe OptionsData + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ApplicationCommandData where + parseJSON = + withObject + "ApplicationCommandData" + ( \v -> do + aci <- v .: "id" + name <- v .: "name" + rd <- v .:? "resolved_data" + t <- v .: "type" :: Parser Int + case t of + 1 -> + ApplicationCommandDataChatInput aci name rd + <$> v .:? "options" + 2 -> + ApplicationCommandDataUser aci name rd + <$> v .: "target_id" + 3 -> + ApplicationCommandDataMessage aci name rd + <$> v .: "target_id" + _ -> fail "unknown interaction data component type" + ) + +-- | Either subcommands and groups, or values. +data OptionsData + = OptionsDataSubcommands [OptionDataSubcommandOrGroup] + | OptionsDataValues [OptionDataValue] + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionsData where + parseJSON = + withArray + "OptionsData" + ( \a -> do + let a' = toList a + case a' of + [] -> return $ OptionsDataValues [] + (v' : _) -> + withObject + "OptionsData item" + ( \v -> do + t <- v .: "type" :: Parser Int + if t == 1 || t == 2 + then OptionsDataSubcommands <$> mapM parseJSON a' + else OptionsDataValues <$> mapM parseJSON a' + ) + v' + ) + +-- | Either a subcommand group or a subcommand. +data OptionDataSubcommandOrGroup + = OptionDataSubcommandGroup + { optionDataSubcommandGroupName :: T.Text, + optionDataSubcommandGroupOptions :: [OptionDataSubcommand], + optionDataSubcommandGroupFocused :: Bool + } + | OptionDataSubcommandOrGroupSubcommand OptionDataSubcommand + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionDataSubcommandOrGroup where + parseJSON = + withObject + "OptionDataSubcommandOrGroup" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 2 -> + OptionDataSubcommandGroup + <$> v .: "name" + <*> v .: "options" + <*> v .:? "focused" .!= False + 1 -> OptionDataSubcommandOrGroupSubcommand <$> parseJSON (Object v) + _ -> fail "unexpected subcommand group type" + ) + +-- | Data for a single subcommand. +data OptionDataSubcommand = OptionDataSubcommand + { optionDataSubcommandName :: T.Text, + optionDataSubcommandOptions :: [OptionDataValue], + optionDataSubcommandFocused :: Bool + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionDataSubcommand where + parseJSON = + withObject + "OptionDataSubcommand" + ( \v -> do + t <- v .: "type" :: Parser Int + case t of + 1 -> + OptionDataSubcommand + <$> v .: "name" + <*> v .:? "options" .!= [] + <*> v .:? "focused" .!= False + _ -> fail "unexpected subcommand type" + ) + +-- | Data for a single value. +data OptionDataValue + = OptionDataValueString + { optionDataValueName :: T.Text, + optionDataValueString :: Either T.Text T.Text + } + | OptionDataValueInteger + { optionDataValueName :: T.Text, + optionDataValueInteger :: Either T.Text Integer + } + | OptionDataValueBoolean + { optionDataValueName :: T.Text, + optionDataValueBoolean :: Bool + } + | OptionDataValueUser + { optionDataValueName :: T.Text, + optionDataValueUser :: UserId + } + | OptionDataValueChannel + { optionDataValueName :: T.Text, + optionDataValueChannel :: ChannelId + } + | OptionDataValueRole + { optionDataValueName :: T.Text, + optionDataValueRole :: RoleId + } + | OptionDataValueMentionable + { optionDataValueName :: T.Text, + optionDataValueMentionable :: Snowflake + } + | OptionDataValueNumber + { optionDataValueName :: T.Text, + optionDataValueNumber :: Either T.Text Number + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON OptionDataValue where + parseJSON = + withObject + "OptionDataValue" + ( \v -> do + name <- v .: "name" + focused <- v .:? "focused" .!= False + t <- v .: "type" :: Parser Int + case t of + 3 -> + OptionDataValueString name + <$> parseValue v focused + 4 -> + OptionDataValueInteger name + <$> parseValue v focused + 10 -> + OptionDataValueNumber name + <$> parseValue v focused + 5 -> + OptionDataValueBoolean name + <$> v .: "value" + 6 -> + OptionDataValueUser name + <$> v .: "value" + 7 -> + OptionDataValueChannel name + <$> v .: "value" + 8 -> + OptionDataValueRole name + <$> v .: "value" + 9 -> + OptionDataValueMentionable name + <$> v .: "value" + _ -> fail $ "unexpected interaction data application command option value type: " ++ show t + ) + +data ModalData = ModalData + { -- | The unique id of the component (up to 100 characters). + modalDataCustomId :: T.Text, + -- | Components from the modal. + modalDataComponents :: [TextInput] + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ModalData where + parseJSON = + withObject + "ModalData" + ( \v -> + ModalData <$> v .: "custom_id" + <*> ((v .: "components") >>= (join <$>) . mapM getTextInput) + ) + where + getTextInput :: Value -> Parser [TextInput] + getTextInput = withObject "ModalData.TextInput" $ \o -> do + t <- o .: "type" :: Parser Int + case t of + 1 -> o .: "components" + _ -> fail $ "expected action row type (1), got: " ++ show t + +parseValue :: (FromJSON a) => Object -> Bool -> Parser (Either T.Text a) +parseValue o True = Left <$> o .: "value" +parseValue o False = Right <$> o .: "value" + +-- resolved data -- this should be formalised and integrated, instead of being +-- left as values + +-- | I'm not sure what this stuff is, so you're on your own. +-- +-- It's not worth the time working out how to create this stuff. +-- If you need to extract from these values, check out the link below. +-- +-- https://discord.com/developers/docs/interactions/receiving-and-responding#interaction-object-resolved-data-structure +data ResolvedData = ResolvedData + { resolvedDataUsers :: Maybe Value, + resolvedDataMembers :: Maybe Value, + resolvedDataRoles :: Maybe Value, + resolvedDataChannels :: Maybe Value, + resolvedDataMessages :: Maybe Value, + resolvedDataAttachments :: Maybe Value + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON ResolvedData where + toJSON ResolvedData {..} = + objectFromMaybes + [ "users" .=? resolvedDataUsers, + "members" .=? resolvedDataMembers, + "roles" .=? resolvedDataRoles, + "channels" .=? resolvedDataChannels, + "messages" .=? resolvedDataMessages, + "attachments" .=? resolvedDataAttachments + ] + +instance FromJSON ResolvedData where + parseJSON = + withObject + "ResolvedData" + ( \v -> + ResolvedData + <$> v .:? "users" + <*> v .:? "members" + <*> v .:? "roles" + <*> v .:? "channels" + <*> v .:? "messages" + <*> v .:? "attachments" + ) + +-- | The data to respond to an interaction with. Unless specified otherwise, you +-- only have three seconds to reply to an interaction before a failure state is +-- given. +data InteractionResponse + = -- | ACK a Ping + InteractionResponsePong + | -- | Respond to an interaction with a message + InteractionResponseChannelMessage InteractionResponseMessage + | -- | ACK an interaction and edit a response later (use `CreateFollowupInteractionMessage` and `InteractionResponseMessage` to do so). User sees loading state. + InteractionResponseDeferChannelMessage + | -- | for components, ACK an interaction and edit the original message later; the user does not see a loading state. + InteractionResponseDeferUpdateMessage + | -- | for components, edit the message the component was attached to + InteractionResponseUpdateMessage InteractionResponseMessage + | -- | respond to an autocomplete interaction with suggested choices + InteractionResponseAutocompleteResult InteractionResponseAutocomplete + | -- | respond with a popup modal + InteractionResponseModal InteractionResponseModalData + deriving (Show, Read, Eq, Ord) + +-- | A basic interaction response, sending back the given text. +interactionResponseBasic :: T.Text -> InteractionResponse +interactionResponseBasic t = InteractionResponseChannelMessage (interactionResponseMessageBasic t) + +instance ToJSON InteractionResponse where + toJSON InteractionResponsePong = object [("type", Number 1)] + toJSON InteractionResponseDeferChannelMessage = object [("type", Number 5)] + toJSON InteractionResponseDeferUpdateMessage = object [("type", Number 6)] + toJSON (InteractionResponseChannelMessage ms) = object [("type", Number 4), ("data", toJSON ms)] + toJSON (InteractionResponseUpdateMessage ms) = object [("type", Number 7), ("data", toJSON ms)] + toJSON (InteractionResponseAutocompleteResult ms) = object [("type", Number 8), ("data", toJSON ms)] + toJSON (InteractionResponseModal ms) = object [("type", Number 9), ("data", toJSON ms)] + +data InteractionResponseAutocomplete + = InteractionResponseAutocompleteString [Choice T.Text] + | InteractionResponseAutocompleteInteger [Choice Integer] + | InteractionResponseAutocompleteNumber [Choice Number] + deriving (Show, Read, Eq, Ord) + +instance ToJSON InteractionResponseAutocomplete where + toJSON (InteractionResponseAutocompleteString cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteInteger cs) = object [("choices", toJSON cs)] + toJSON (InteractionResponseAutocompleteNumber cs) = object [("choices", toJSON cs)] + +-- | A cut down message structure. +data InteractionResponseMessage = InteractionResponseMessage + { interactionResponseMessageTTS :: Maybe Bool, + interactionResponseMessageContent :: Maybe T.Text, + interactionResponseMessageEmbeds :: Maybe [CreateEmbed], + interactionResponseMessageAllowedMentions :: Maybe AllowedMentions, + interactionResponseMessageFlags :: Maybe InteractionResponseMessageFlags, + interactionResponseMessageComponents :: Maybe [ActionRow], + interactionResponseMessageAttachments :: Maybe [Attachment] + } + deriving (Show, Read, Eq, Ord) + +-- | A basic interaction response, sending back the given text. This is +-- effectively a helper function. +interactionResponseMessageBasic :: T.Text -> InteractionResponseMessage +interactionResponseMessageBasic t = InteractionResponseMessage Nothing (Just t) Nothing Nothing Nothing Nothing Nothing + +instance ToJSON InteractionResponseMessage where + toJSON InteractionResponseMessage {..} = + objectFromMaybes + [ "tts" .=? interactionResponseMessageTTS, + "content" .=? interactionResponseMessageContent, + "embeds" .=? ((createEmbed <$>) <$> interactionResponseMessageEmbeds), + "allowed_mentions" .=? interactionResponseMessageAllowedMentions, + "flags" .=? interactionResponseMessageFlags, + "components" .=? interactionResponseMessageComponents, + "attachments" .=? interactionResponseMessageAttachments + ] + +-- | Types of flags to attach to the interaction message. +-- +-- Currently the only flag is EPHERMERAL, which means only the user can see the +-- message. +data InteractionResponseMessageFlag = InteractionResponseMessageFlagEphermeral + deriving (Show, Read, Eq, Ord) + +newtype InteractionResponseMessageFlags = InteractionResponseMessageFlags [InteractionResponseMessageFlag] + deriving (Show, Read, Eq, Ord) + +instance Enum InteractionResponseMessageFlag where + fromEnum InteractionResponseMessageFlagEphermeral = 1 `shift` 6 + toEnum i + | i == 1 `shift` 6 = InteractionResponseMessageFlagEphermeral + | otherwise = error $ "could not find InteractionCallbackDataFlag `" ++ show i ++ "`" + +instance ToJSON InteractionResponseMessageFlags where + toJSON (InteractionResponseMessageFlags fs) = Number $ fromInteger $ fromIntegral $ foldr (.|.) 0 (fromEnum <$> fs) + +data InteractionResponseModalData = InteractionResponseModalData + { interactionResponseModalCustomId :: T.Text, + interactionResponseModalTitle :: T.Text, + interactionResponseModalComponents :: [TextInput] + } + deriving (Show, Read, Eq, Ord) + +instance ToJSON InteractionResponseModalData where + toJSON InteractionResponseModalData {..} = + object + [ ("custom_id", toJSON interactionResponseModalCustomId), + ("title", toJSON interactionResponseModalTitle), + ("components", toJSON $ map (\ti -> object [("type", Number 1), ("components", toJSON [ti])]) interactionResponseModalComponents) + ] diff --git a/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs new file mode 100644 index 0000000..fd49a15 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/Prelude.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Provides base types and utility functions needed for modules in Discord.Internal.Types +module Discord.Internal.Types.Prelude + ( Auth (..) + , authToken + + , Snowflake (..) + , snowflakeCreationDate + + , RolePermissions (..) + + , DiscordId (..) + , ChannelId + , StageId + , GuildId + , MessageId + , AttachmentId + , EmojiId + , StickerId + , UserId + , RoleId + , IntegrationId + , WebhookId + , ParentId + , ApplicationId + , ApplicationCommandId + , InteractionId + , ScheduledEventId + , ScheduledEventEntityId + + , DiscordToken (..) + , InteractionToken + , WebhookToken + + , Shard + , epochTime + + , InternalDiscordEnum (..) + + , Base64Image (..) + , getMimeType + + , (.==) + , (.=?) + , AesonKey + , objectFromMaybes + + , ChannelTypeOption (..) + ) + + where + +import Data.Bifunctor (first) +import Data.Bits (Bits(shiftR)) +import Data.Data (Data (dataTypeOf), dataTypeConstrs, fromConstr) +import Data.Word (Word64) +import Data.Maybe (catMaybes) +import Text.Read (readMaybe) + +import Data.Aeson.Types +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Web.Internal.HttpApiData + +import qualified Data.ByteString as B +import qualified Data.Text as T + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#endif + +-- | Authorization token for the Discord API +newtype Auth = Auth T.Text + deriving (Show, Read, Eq, Ord) + + +-- | Get the raw token formatted for use with the websocket gateway +authToken :: Auth -> T.Text +authToken (Auth tok) = let token = T.strip tok + bot = if "Bot " `T.isPrefixOf` token then "" else "Bot " + in bot <> token + +-- | A unique integer identifier. Can be used to calculate the creation date of an entity. +newtype Snowflake = Snowflake { unSnowflake :: Word64 } + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) + +instance Show Snowflake where + show (Snowflake a) = show a + +instance Read Snowflake where + readsPrec p = fmap (first Snowflake) . readsPrec p + +instance ToJSON Snowflake where + toJSON (Snowflake snowflake) = String . T.pack $ show snowflake + +instance FromJSON Snowflake where + parseJSON = + withText + "Snowflake" + ( \snowflake -> + case readMaybe (T.unpack snowflake) of + Nothing -> fail "null snowflake" + (Just i) -> pure i + ) + +instance ToHttpApiData Snowflake where + toUrlPiece = T.pack . show + +newtype RolePermissions = RolePermissions { getRolePermissions :: Integer } + deriving (Eq, Ord, Num, Bits, Enum, Real, Integral) + +instance Read RolePermissions where + readsPrec p = fmap (first RolePermissions) . readsPrec p + +instance ToJSON RolePermissions where + toJSON = toJSON . getRolePermissions + +-- In v8 and above, all permissions are serialized as strings. +-- See https://discord.com/developers/docs/topics/permissions#permissions. +instance FromJSON RolePermissions where + parseJSON = withText "RolePermissions" $ + \text -> case readMaybe (T.unpack text) of + Just perms -> pure $ RolePermissions perms + Nothing -> fail "invalid role permissions integer string" + +instance Show RolePermissions where + show = show . getRolePermissions + +newtype DiscordId a = DiscordId { unId :: Snowflake } + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) + +instance Show (DiscordId a) where + show = show . unId + +instance Read (DiscordId a) where + readsPrec p = fmap (first DiscordId) . readsPrec p + +instance ToJSON (DiscordId a) where + toJSON = toJSON . unId + +instance FromJSON (DiscordId a) where + parseJSON = fmap DiscordId . parseJSON + +instance ToHttpApiData (DiscordId a) where + toUrlPiece = T.pack . show + +data ChannelIdType +type ChannelId = DiscordId ChannelIdType + +data StageIdType +type StageId = DiscordId StageIdType + +data GuildIdType +type GuildId = DiscordId GuildIdType + +data MessageIdType +type MessageId = DiscordId MessageIdType + +data AttachmentIdType +type AttachmentId = DiscordId AttachmentIdType + +data EmojiIdType +type EmojiId = DiscordId EmojiIdType + +data StickerIdType +type StickerId = DiscordId StickerIdType + +data UserIdType +type UserId = DiscordId UserIdType + +data RoleIdType +type RoleId = DiscordId RoleIdType + +data IntegrationIdType +type IntegrationId = DiscordId IntegrationIdType + +data WebhookIdType +type WebhookId = DiscordId WebhookIdType + +data ParentIdType +type ParentId = DiscordId ParentIdType + +data ApplicationIdType +type ApplicationId = DiscordId ApplicationIdType + +data ApplicationCommandIdType +type ApplicationCommandId = DiscordId ApplicationCommandIdType + +data InteractionIdType +type InteractionId = DiscordId InteractionIdType + +data ScheduledEventIdType +type ScheduledEventId = DiscordId ScheduledEventIdType + +data ScheduledEventEntityIdType +type ScheduledEventEntityId = DiscordId ScheduledEventEntityIdType + +newtype DiscordToken a = DiscordToken { unToken :: T.Text } + deriving (Ord, Eq) + +instance Show (DiscordToken a) where + show = show . unToken + +instance Read (DiscordToken a) where + readsPrec p = fmap (first DiscordToken) . readsPrec p + +instance ToJSON (DiscordToken a) where + toJSON = toJSON . unToken + +instance FromJSON (DiscordToken a) where + parseJSON = fmap DiscordToken . parseJSON + +instance ToHttpApiData (DiscordToken a) where + toUrlPiece = unToken + +type InteractionToken = DiscordToken InteractionIdType + +type WebhookToken = DiscordToken WebhookIdType + +type Shard = (Int, Int) + +-- | Gets a creation date from a snowflake. +snowflakeCreationDate :: Snowflake -> UTCTime +snowflakeCreationDate x = posixSecondsToUTCTime . realToFrac + $ 1420070400 + quot (shiftR x 22) 1000 + +-- | Default timestamp +epochTime :: UTCTime +epochTime = posixSecondsToUTCTime 0 + +{- + +InternalDiscordEnum is a hack-y typeclass, but it's the best solution overall. +The best we can do is prevent the end-user from seeing this. + +typeclass Bounded (minBound + maxBound) could replace discordTypeStartValue, but +it can't derive instances for types like DiscordColor, which have simple sum types involved. + +typeclass Enum (toEnum + fromEnum) requires defining both A->Int and Int->A. +If we handle both at once (with an inline map), it's no longer typesafe. + +External packages exist, but bloat our dependencies + +-} +class Data a => InternalDiscordEnum a where + discordTypeStartValue :: a + fromDiscordType :: a -> Int + discordTypeTable :: [(Int, a)] + discordTypeTable = map (\d -> (fromDiscordType d, d)) (makeTable discordTypeStartValue) + where + makeTable :: Data b => b -> [b] + makeTable t = map fromConstr (dataTypeConstrs $ dataTypeOf t) + + discordTypeParseJSON :: String -> Value -> Parser a + discordTypeParseJSON name = + withScientific + name + ( \i -> do + case maybeInt i >>= (`lookup` discordTypeTable) of + Nothing -> fail $ "could not parse type: " ++ show i + Just d -> return d + ) + where + maybeInt i + | fromIntegral (round i) == i = Just $ round i + | otherwise = Nothing + +-- Aeson 2.0 uses KeyMaps with a defined Key type for its objects. Aeson up to +-- 1.5 uses HashMaps with Text for the key. Both types have an IsString instance. +-- To keep our version bounds as loose as possible while the Haskell ecosystem +-- (and thus our users) switch over to Aeson 2.0, we use some CPP to define a +-- AesonKey as an alias. +#if MIN_VERSION_aeson(2, 0, 0) +type AesonKey = Key.Key +#else +type AesonKey = T.Text +#endif + + +(.==) :: ToJSON a => AesonKey -> a -> Maybe Pair +k .== v = Just (k .= v) + +(.=?) :: ToJSON a => AesonKey -> Maybe a -> Maybe Pair +k .=? (Just v) = Just (k .= v) +_ .=? Nothing = Nothing + +objectFromMaybes :: [Maybe Pair] -> Value +objectFromMaybes = object . catMaybes + + +-- | @Base64Image mime data@ represents the base64 encoding of an image (as +-- @data@), together with a tag of its mime type (@mime@). The constructor is +-- only for Internal use, and its public export is hidden in Discord.Types. +-- +-- Public creation of this datatype should be done using the relevant smart +-- constructors for Emoji, Sticker, or Avatar. +data Base64Image a = Base64Image T.Text T.Text + deriving (Show, Read, Eq, Ord) + +-- | The ToJSON instance for Base64Image creates a string representation of the +-- image's base-64 data, suited for using as JSON values. +-- +-- The format is: @data:%MIME%;base64,%DATA%@. +instance ToJSON (Base64Image a) where + toJSON (Base64Image mime im) = String $ "data:" <> mime <> ";base64," <> im + +-- | @getMimeType bs@ returns a possible mimetype for the given bytestring, +-- based on the first few magic bytes. It may return any of PNG/JPEG/GIF or WEBP +-- mimetypes, or Nothing if none are matched. +-- +-- Reference: https://en.wikipedia.org/wiki/List_of_file_signatures +-- +-- Although Discord's official documentation does not state WEBP as a supported +-- format, it has been accepted for both emojis and user avatars no problem +-- when tested manually. +-- +-- /Inspired by discord.py's implementation./ +getMimeType :: B.ByteString -> Maybe T.Text +getMimeType bs + | B.take 8 bs == "\x89\x50\x4E\x47\x0D\x0A\x1A\x0A" + = Just "image/png" + | B.take 3 bs == "\xff\xd8\xff" || B.take 4 (B.drop 6 bs) `elem` ["JFIF", "Exif"] + = Just "image/jpeg" + | B.take 6 bs == "\x47\x49\x46\x38\x37\x61" || B.take 6 bs == "\x47\x49\x46\x38\x39\x61" + = Just "image/gif" + | B.take 4 bs == "RIFF" && B.take 4 (B.drop 8 bs) == "WEBP" + = Just "image/webp" + | otherwise = Nothing + +-- | The different channel types. Used for application commands and components. +-- +-- https://discord.com/developers/docs/resources/channel#channel-object-channel-types +data ChannelTypeOption + = -- | A text channel in a server. + ChannelTypeOptionGuildText + | -- | A direct message between users. + ChannelTypeOptionDM + | -- | A voice channel in a server. + ChannelTypeOptionGuildVoice + | -- | A direct message between multiple users. + ChannelTypeOptionGroupDM + | -- | An organizational category that contains up to 50 channels. + ChannelTypeOptionGuildCategory + | -- | A channel that users can follow and crosspost into their own server. + ChannelTypeOptionGuildNews + | -- | A channel in which game developers can sell their game on discord. + ChannelTypeOptionGuildStore + | -- | A temporary sub-channel within a guild_news channel. + ChannelTypeOptionGuildNewsThread + | -- | A temporary sub-channel within a guild_text channel. + ChannelTypeOptionGuildPublicThread + | -- | A temporary sub-channel within a GUILD_TEXT channel that is only + -- viewable by those invited and those with the MANAGE_THREADS permission + ChannelTypeOptionGuildPrivateThread + | -- | A voice channel for hosting events with an audience. + ChannelTypeOptionGuildStageVoice + deriving (Show, Read, Data, Eq, Ord) + +instance InternalDiscordEnum ChannelTypeOption where + discordTypeStartValue = ChannelTypeOptionGuildText + fromDiscordType ChannelTypeOptionGuildText = 0 + fromDiscordType ChannelTypeOptionDM = 1 + fromDiscordType ChannelTypeOptionGuildVoice = 2 + fromDiscordType ChannelTypeOptionGroupDM = 3 + fromDiscordType ChannelTypeOptionGuildCategory = 4 + fromDiscordType ChannelTypeOptionGuildNews = 5 + fromDiscordType ChannelTypeOptionGuildStore = 6 + fromDiscordType ChannelTypeOptionGuildNewsThread = 10 + fromDiscordType ChannelTypeOptionGuildPublicThread = 11 + fromDiscordType ChannelTypeOptionGuildPrivateThread = 12 + fromDiscordType ChannelTypeOptionGuildStageVoice = 13 + +instance ToJSON ChannelTypeOption where + toJSON = toJSON . fromDiscordType + +instance FromJSON ChannelTypeOption where + parseJSON = discordTypeParseJSON "ChannelTypeOption" diff --git a/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs new file mode 100644 index 0000000..3044e9e --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/RolePermissions.hs @@ -0,0 +1,119 @@ +module Discord.Internal.Types.RolePermissions + ( PermissionFlag (..), + hasRolePermissions, + hasRolePermission, + newRolePermissions, + newRolePermission, + setRolePermissions, + setRolePermission, + clearRolePermissions, + clearRolePermission, + hasGuildMemberPermission, + ) +where + +import Data.Bits (Bits (complement, shift, (.&.), (.|.))) +import Discord.Internal.Types.Guild + ( Guild, + Role (rolePerms), + roleIdToRole, + ) +import Discord.Internal.Types.Prelude (RolePermissions) +import Discord.Internal.Types.User (GuildMember (memberRoles)) + +data PermissionFlag + = CREATE_INSTANT_INVITE + | KICK_MEMBERS + | BAN_MEMBERS + | ADMINISTRATOR + | MANAGE_CHANNELS + | MANAGE_GUILD + | ADD_REACTIONS + | VIEW_AUDIT_LOG + | PRIORITY_SPEAKER + | STREAM + | VIEW_CHANNEL + | SEND_MESSAGES + | SEND_TTS_MESSAGES + | MANAGE_MESSAGES + | EMBED_LINKS + | ATTACH_FILES + | READ_MESSAGE_HISTORY + | MENTION_EVERYONE + | USE_EXTERNAL_EMOJIS + | VIEW_GUILD_INSIGHT + | CONNECT + | SPEAK + | MUTE_MEMBERS + | DEAFEN_MEMBERS + | MOVE_MEMBERS + | USE_VAD + | CHANGE_NICKNAME + | MANAGE_NICKNAMES + | MANAGE_ROLES + | MANAGE_WEBHOOKS + | MANAGE_EMOJIS_AND_STICKERS + | USE_APPLICATION_COMMANDS + | REQUEST_TO_SPEAK + | MANAGE_EVENTS + | MANAGE_THREADS + | CREATE_PUBLIC_THREADS + | CREATE_PRIVATE_THREADS + | USE_EXTERNAL_STICKERS + | SEND_MESSAGES_IN_THREADS + | USE_EMBEDDED_ACTIVITIES + | MODERATE_MEMBERS + deriving (Eq, Ord, Enum, Show) + +permissionBits :: PermissionFlag -> RolePermissions +permissionBits p = shift 1 (fromEnum p) + +-- | Check if a given role has all the permissions +hasRolePermissions :: [PermissionFlag] -> RolePermissions -> Bool +hasRolePermissions permissions rolePermissions = (.&.) combinedPermissions rolePermissions == combinedPermissions + where + combinedPermissions = combinePermissions permissions + +-- | Check if a given role has the permission +hasRolePermission :: PermissionFlag -> RolePermissions -> Bool +hasRolePermission p r = (.&.) (permissionBits p) r > 0 + +-- | Replace a users rolePerms +-- with a complete new set of permissions +newRolePermissions :: [PermissionFlag] -> RolePermissions +newRolePermissions = combinePermissions + +-- | Get the RolePermissions of a single PermissionFlag +newRolePermission :: PermissionFlag -> RolePermissions +newRolePermission = permissionBits + +-- | Update RolePermissions with new permissions +setRolePermissions :: [PermissionFlag] -> RolePermissions -> RolePermissions +setRolePermissions p r = combinePermissions p .|. r + +-- | Unset Permissions from RolePermissions +clearRolePermissions :: [PermissionFlag] -> RolePermissions -> RolePermissions +clearRolePermissions p r = (complement . combinePermissions) p .&. r + +-- | Set a certain permission flag +-- This method doesn't lose the other already present permissions +setRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions +setRolePermission p = (.|.) (permissionBits p) + +-- | Remove a permission from a user by clearing the bit +clearRolePermission :: PermissionFlag -> RolePermissions -> RolePermissions +clearRolePermission p = (.&.) (complement . permissionBits $ p) + +combinePermissions :: [PermissionFlag] -> RolePermissions +combinePermissions = foldr ((.|.) . permissionBits) 0 + +-- | Check if any Role of an GuildMember has the needed permission +-- If the result of roleIdToRole is Nothing, it prepends a "False" +-- Otherwise it checks for the needed permission +hasGuildMemberPermission :: Guild -> GuildMember -> PermissionFlag -> Bool +hasGuildMemberPermission g gm p = go (memberRoles gm) + where + go [] = False + go (x : xs) = case roleIdToRole g x of + Nothing -> go xs + Just a -> p `hasRolePermission` rolePerms a || go xs diff --git a/deps/discord-haskell/src/Discord/Internal/Types/ScheduledEvents.hs b/deps/discord-haskell/src/Discord/Internal/Types/ScheduledEvents.hs new file mode 100644 index 0000000..01f37a1 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/ScheduledEvents.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Structures pertaining to Discord Scheduled Events +module Discord.Internal.Types.ScheduledEvents where + +import Data.Aeson ( (.:) + , (.:!) + , (.:?) + , (.=) + , FromJSON(parseJSON) + , ToJSON(toJSON) + , Value(Null, Number, String) + , object + , withObject + , withText + ) +import Data.Aeson.Types ( Parser ) +import qualified Data.ByteString as B +import Data.Data ( Data ) +import Data.Default ( Default(def) ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time ( UTCTime ) +import Discord.Internal.Types.Prelude ( ChannelId + , GuildId + , InternalDiscordEnum + ( discordTypeParseJSON + , discordTypeStartValue + , fromDiscordType + ) + , ScheduledEventEntityId + , ScheduledEventId + , UserId + , (.==) + , (.=?) + , objectFromMaybes + ) +import Discord.Internal.Types.User ( GuildMember + , User + ) + + + +-- | The ScheduledEvent data structure +data ScheduledEvent + = ScheduledEventStage + { scheduledEventStageId :: ScheduledEventId + , scheduledEventStageGuildId :: GuildId + , scheduledEventStageChannelId :: ChannelId + , scheduledEventStageCreatorId :: Maybe UserId + , scheduledEventStageName :: T.Text + , scheduledEventStageDescription :: Maybe T.Text + , scheduledEventStageStartTime :: UTCTime + , scheduledEventStageEndTime :: Maybe UTCTime + , scheduledEventStagePrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventStageStatus :: ScheduledEventStatus + , scheduledEventStageEntityId :: Maybe ScheduledEventEntityId + , scheduledEventStageCreator :: Maybe User + , scheduledEventStageUserCount :: Maybe Integer + , scheduledEventStageImage :: Maybe ScheduledEventImageHash + } + | ScheduledEventVoice + { scheduledEventVoiceId :: ScheduledEventId + , scheduledEventVoiceGuildId :: GuildId + , scheduledEventVoiceChannelId :: ChannelId + , scheduledEventVoiceCreatorId :: Maybe UserId + , scheduledEventVoiceName :: T.Text + , scheduledEventVoiceDescription :: Maybe T.Text + , scheduledEventVoiceStartTime :: UTCTime + , scheduledEventVoiceEndTime :: Maybe UTCTime + , scheduledEventVoicePrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventVoiceStatus :: ScheduledEventStatus + , scheduledEventVoiceEntityId :: Maybe ScheduledEventEntityId + , scheduledEventVoiceCreator :: Maybe User + , scheduledEventVoiceUserCount :: Maybe Integer + , scheduledEventVoiceImage :: Maybe ScheduledEventImageHash + } + | ScheduledEventExternal + { scheduledEventExternalId :: ScheduledEventId + , scheduledEventExternalGuildId :: GuildId + , scheduledEventExternalLocation :: T.Text + , scheduledEventExternalCreatorId :: Maybe UserId + , scheduledEventExternalName :: T.Text + , scheduledEventExternalDescription :: Maybe T.Text + , scheduledEventExternalStartTime :: UTCTime + , scheduledEventExternalEndTime :: UTCTime + , scheduledEventExternalPrivacyLevel :: ScheduledEventPrivacyLevel + , scheduledEventExternalStatus :: ScheduledEventStatus + , scheduledEventExternalEntityId :: Maybe ScheduledEventEntityId + , scheduledEventExternalCreator :: Maybe User + , scheduledEventExternalUserCount :: Maybe Integer + , scheduledEventExternalImage :: Maybe ScheduledEventImageHash + } + deriving (Show, Eq, Read) + +instance ToJSON ScheduledEvent where + toJSON ScheduledEventStage {..} = objectFromMaybes + [ "id" .== scheduledEventStageId + , "guild_id" .== scheduledEventStageGuildId + , "channel_id" .== scheduledEventStageChannelId + , "creator_id" .=? scheduledEventStageCreatorId + , "name" .== scheduledEventStageName + , "description" .=? scheduledEventStageDescription + , "scheduled_start_time" .== scheduledEventStageStartTime + , "scheduled_end_time" .=? scheduledEventStageEndTime + , "privacy_level" .== scheduledEventStagePrivacyLevel + , "entity_type" .== Number 1 + , "entity_id" .=? scheduledEventStageEntityId + , "creator" .=? scheduledEventStageCreator + , "user_count" .=? scheduledEventStageUserCount + , "image" .=? scheduledEventStageImage + ] + toJSON ScheduledEventVoice {..} = objectFromMaybes + [ "id" .== scheduledEventVoiceId + , "guild_id" .== scheduledEventVoiceGuildId + , "channel_id" .== scheduledEventVoiceChannelId + , "creator_id" .=? scheduledEventVoiceCreatorId + , "name" .== scheduledEventVoiceName + , "description" .=? scheduledEventVoiceDescription + , "scheduled_start_time" .== scheduledEventVoiceStartTime + , "scheduled_end_time" .=? scheduledEventVoiceEndTime + , "privacy_level" .== scheduledEventVoicePrivacyLevel + , "entity_type" .== Number 2 + , "entity_id" .=? scheduledEventVoiceEntityId + , "creator" .=? scheduledEventVoiceCreator + , "user_count" .=? scheduledEventVoiceUserCount + , "image" .=? scheduledEventVoiceImage + ] + toJSON ScheduledEventExternal {..} = objectFromMaybes + [ "id" .== scheduledEventExternalId + , "guild_id" .== scheduledEventExternalGuildId + , "creator_id" .=? scheduledEventExternalCreatorId + , "name" .== scheduledEventExternalName + , "description" .=? scheduledEventExternalDescription + , "scheduled_start_time" .== scheduledEventExternalStartTime + , "scheduled_end_time" .== scheduledEventExternalEndTime + , "privacy_level" .== scheduledEventExternalPrivacyLevel + , "entity_type" .== Number 3 + , "entity_id" .=? scheduledEventExternalEntityId + , "creator" .=? scheduledEventExternalCreator + , "user_count" .=? scheduledEventExternalUserCount + , "image" .=? scheduledEventExternalImage + , "entity_metadata" + .== object ["location" .= toJSON scheduledEventExternalLocation] + ] + + +instance FromJSON ScheduledEvent where + parseJSON = withObject + "ScheduledEvent" + (\v -> do + setype <- v .: "entity_type" :: Parser Int + seid <- v .: "id" + segid <- v .: "guild_id" + secrid <- v .:? "creator_id" + sename <- v .: "name" + sedesc <- v .:? "description" + sest <- v .: "scheduled_start_time" + sepl <- v .: "privacy_level" :: Parser ScheduledEventPrivacyLevel + sestat <- v .: "status" :: Parser ScheduledEventStatus + seeid <- v .:? "entity_id" + secrea <- v .:? "creator" + seuc <- v .:? "user_count" + seim <- v .:? "image" + + case setype of + 1 -> do + sechid <- v .: "channelId" + seet <- v .:? "scheduled_end_time" + return $ ScheduledEventStage seid + segid + sechid + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + 2 -> do + sechid <- v .: "channelId" + seet <- v .:? "scheduled_end_time" + return $ ScheduledEventVoice seid + segid + sechid + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + 3 -> do + semeta <- v .: "entity_metadata" + seloc <- withObject "entity_metadata" (.: "location") semeta + seet <- v .: "scheduled_end_time" + return $ ScheduledEventExternal seid + segid + seloc + secrid + sename + sedesc + sest + seet + sepl + sestat + seeid + secrea + seuc + seim + _ -> error "unreachable" + ) + +-- | The privacy level of a scheduled event +data ScheduledEventPrivacyLevel = ScheduledEventPrivacyLevelGuildOnly + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ScheduledEventPrivacyLevel where + discordTypeStartValue = ScheduledEventPrivacyLevelGuildOnly + fromDiscordType ScheduledEventPrivacyLevelGuildOnly = 2 + +instance ToJSON ScheduledEventPrivacyLevel where + toJSON = toJSON . fromDiscordType + +instance FromJSON ScheduledEventPrivacyLevel where + parseJSON = discordTypeParseJSON "ScheduledEventPrivacyLevel" + +-- | The Status of a Scheduled Event +data ScheduledEventStatus + = ScheduledEventStatusScheduled + | ScheduledEventStatusActive + | ScheduledEventStatusCompleted + | ScheduledEventStatusCancelled + deriving (Show, Read, Eq, Ord, Data) + +instance InternalDiscordEnum ScheduledEventStatus where + discordTypeStartValue = ScheduledEventStatusScheduled + fromDiscordType ScheduledEventStatusScheduled = 1 + fromDiscordType ScheduledEventStatusActive = 2 + fromDiscordType ScheduledEventStatusCompleted = 3 + fromDiscordType ScheduledEventStatusCancelled = 4 + +instance ToJSON ScheduledEventStatus where + toJSON = toJSON . fromDiscordType + +instance FromJSON ScheduledEventStatus where + parseJSON = discordTypeParseJSON "ScheduledEventStatus" + +-- | The hash of the cover image of a ScheduledEvent +type ScheduledEventImageHash = T.Text + +-- | The type of images that can be uploaded +data CreateScheduledEventImageUploadType + = CreateScheduledEventImageUploadTypeJPG + | CreateScheduledEventImageUploadTypePNG + | CreateScheduledEventImageUploadTypeGIF + deriving (Show, Read, Eq, Ord) + +-- | The required information to add a cover image to a Scheduled Event +data CreateScheduledEventImage + = CreateScheduledEventImageURL T.Text + | CreateScheduledEventImageUpload CreateScheduledEventImageUploadType B.ByteString + deriving (Show, Read, Eq, Ord) + +instance ToJSON CreateScheduledEventImage where + toJSON (CreateScheduledEventImageURL u) = String u + toJSON (CreateScheduledEventImageUpload typ bs) = + String + $ "data:" + <> (case typ of + CreateScheduledEventImageUploadTypeJPG -> "image/jpeg" + CreateScheduledEventImageUploadTypePNG -> "image/png" + CreateScheduledEventImageUploadTypeGIF -> "image/gif" + ) + <> ";base64," + <> T.decodeUtf8 bs + +instance FromJSON CreateScheduledEventImage where + parseJSON = + withText "CreateScheduledEventImage" (return . CreateScheduledEventImageURL) + +-- | Data required to create a Scheduled Event +data CreateScheduledEventData + = CreateScheduledEventDataStage + { createScheduleEventDataStageChannelId :: ChannelId + , createScheduleEventDataStageName :: T.Text + , createScheduleEventDataStagePrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataStageStartTime :: UTCTime + , createScheduleEventDataStageEndTime :: Maybe UTCTime + , createScheduleEventDataStageDescription :: Maybe T.Text + , createScheduleEventDataStageImage :: Maybe CreateScheduledEventImage + } + | CreateScheduledEventDataVoice + { createScheduleEventDataVoiceChannelId :: ChannelId + , createScheduleEventDataVoiceName :: T.Text + , createScheduleEventDataVoicePrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataVoiceStartTime :: UTCTime + , createScheduleEventDataVoiceEndTime :: Maybe UTCTime + , createScheduleEventDataVoiceDescription :: Maybe T.Text + , createScheduleEventDataVoiceImage :: Maybe CreateScheduledEventImage + } + | CreateScheduledEventDataExternal + { createScheduleEventDataExternalLocation :: T.Text + , createScheduleEventDataExternalName :: T.Text + , createScheduleEventDataExternalPrivacyLevel :: ScheduledEventPrivacyLevel + , createScheduleEventDataExternalStartTime :: UTCTime + , createScheduleEventDataExternalEndTime :: UTCTime + , createScheduleEventDataExternalDescription :: Maybe T.Text + , createScheduleEventDataExternalImage :: Maybe CreateScheduledEventImage + } + +instance ToJSON CreateScheduledEventData where + toJSON CreateScheduledEventDataStage {..} = objectFromMaybes + [ "channel_id" .== createScheduleEventDataStageChannelId + , "name" .== createScheduleEventDataStageName + , "privacy_level" .== createScheduleEventDataStagePrivacyLevel + , "scheduled_start_time" .== createScheduleEventDataStageStartTime + , "scheduled_end_time" .=? createScheduleEventDataStageEndTime + , "description" .=? createScheduleEventDataStageDescription + , "entity_type" .== Number 1 + , "image" .=? createScheduleEventDataStageImage + ] + toJSON CreateScheduledEventDataVoice {..} = objectFromMaybes + [ "channel_id" .== createScheduleEventDataVoiceChannelId + , "name" .== createScheduleEventDataVoiceName + , "privacy_level" .== createScheduleEventDataVoicePrivacyLevel + , "scheduled_start_time" .== createScheduleEventDataVoiceStartTime + , "scheduled_end_time" .=? createScheduleEventDataVoiceEndTime + , "description" .=? createScheduleEventDataVoiceDescription + , "entity_type" .== Number 2 + , "image" .=? createScheduleEventDataVoiceImage + ] + toJSON CreateScheduledEventDataExternal {..} = objectFromMaybes + [ "entity_metadata" + .== object ["location" .= createScheduleEventDataExternalLocation] + , "name" .== createScheduleEventDataExternalName + , "privacy_level" .== createScheduleEventDataExternalPrivacyLevel + , "scheduled_start_time" .== createScheduleEventDataExternalStartTime + , "scheduled_end_time" .== createScheduleEventDataExternalEndTime + , "description" .=? createScheduleEventDataExternalDescription + , "entity_type" .== Number 2 + , "image" .=? createScheduleEventDataExternalImage + ] + +instance FromJSON CreateScheduledEventData where + parseJSON = withObject + "CreateScheduledEventData" + (\v -> do + t <- v .: "entity_type" :: Parser Int + csename <- v .: "name" + csepl <- v .: "privacy_level" + csest <- v .: "scheduled_start_time" + csedesc <- v .:? "description" + cseimg <- v .:? "image" + + case t of + 1 -> do + csecid <- v .: "channel_id" + cseet <- v .:? "scheduled_end_time" + return $ CreateScheduledEventDataStage csecid + csename + csepl + csest + cseet + csedesc + cseimg + 2 -> do + csecid <- v .: "channel_id" + cseet <- v .:? "scheduled_end_time" + return $ CreateScheduledEventDataVoice csecid + csename + csepl + csest + cseet + csedesc + cseimg + 3 -> do + csemeta <- v .: "entity_metadata" + cseloc <- withObject "entity_metadata" (.: "location") csemeta + cseet <- v .: "scheduled_end_time" + return $ CreateScheduledEventDataVoice cseloc + csename + csepl + csest + cseet + csedesc + cseimg + _ -> error "unreachable" + ) + + +-- | The type of ScheduledEvent, used in 'ModifyScheduledEventData' +data ScheduledEventType + = ScheduledEventTypeStage + | ScheduledEventTypeVoice + | ScheduledEventTypeExternal + deriving (Show, Read, Ord, Eq, Data) + +instance InternalDiscordEnum ScheduledEventType where + discordTypeStartValue = ScheduledEventTypeStage + fromDiscordType ScheduledEventTypeStage = 1 + fromDiscordType ScheduledEventTypeVoice = 2 + fromDiscordType ScheduledEventTypeExternal = 3 + +instance FromJSON ScheduledEventType where + parseJSON = discordTypeParseJSON "ScheduledEventType" + +instance ToJSON ScheduledEventType where + toJSON = toJSON . fromDiscordType + +-- | Data required to issue a Modify Scheduled Event request +-- This isnt fully type-safe, and can allow for boggus requests but I don't +-- know of any sane solution to this +data ModifyScheduledEventData = ModifyScheduledEventData + { modifyScheduledEventDataChannelId :: Maybe (Maybe ChannelId) + , modifyScheduledEventDataLocation :: Maybe (Maybe T.Text) + , modifyScheduledEventDataName :: Maybe T.Text + , modifyScheduledEventDataPrivacyLevel :: Maybe ScheduledEventPrivacyLevel + , modifyScheduledEventDataStartTime :: Maybe UTCTime + , modifyScheduledEventDataEndTime :: Maybe UTCTime + , modifyScheduledEventDataDescription :: Maybe (Maybe T.Text) + , modifyScheduledEventDataType :: Maybe ScheduledEventType + , modifyScheduledEventDataStatus :: Maybe ScheduledEventStatus + , modifyScheduledEventDataImage :: Maybe CreateScheduledEventImage + } + +instance Default ModifyScheduledEventData where + def = ModifyScheduledEventData Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +instance ToJSON ModifyScheduledEventData where + toJSON ModifyScheduledEventData {..} = objectFromMaybes + [ "channel_id" .=? modifyScheduledEventDataChannelId + , "entity_metadata" .=? loc + , "name" .=? modifyScheduledEventDataName + , "scheduled_start_time" .=? modifyScheduledEventDataStartTime + , "scheduled_end_time" .=? modifyScheduledEventDataEndTime + , "description" .=? modifyScheduledEventDataDescription + , "entity_type" .=? modifyScheduledEventDataType + , "status" .=? modifyScheduledEventDataStatus + , "image" .=? modifyScheduledEventDataImage + ] + where + loc = case modifyScheduledEventDataLocation of + Nothing -> Nothing + Just Nothing -> Just Null + Just loc' -> Just $ object [("location", toJSON loc')] + +instance FromJSON ModifyScheduledEventData where + parseJSON = withObject + "ModifyScheduledEventData" + (\v -> do + -- The trivial fields + msename <- v .:? "name" + msest <- v .:? "scheduled_start_time" + mseet <- v .:? "scheduled_end_time" + msetype <- v .:? "entity_type" + msepl <- v .:? "privacy_level" + msestat <- v .:? "status" + mseimg <- v .:? "image" + + -- The not so trivial ones + msecid' <- v .:! "channel_id" + mseloc' <- v .:! "entity_metadata" + msedesc' <- v .:! "description" + + -- Extract the values + msecid <- case msecid' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- parseJSON x + return $ Just x' + + mseloc <- case mseloc' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- withObject "entity_metadata" (.: "location") x + return $ Just x' + + msedesc <- case msedesc' of + Nothing -> return Nothing + Just Null -> return $ Just Nothing + Just x -> do + x' <- parseJSON x + return $ Just x' + + return $ ModifyScheduledEventData + { modifyScheduledEventDataChannelId = msecid + , modifyScheduledEventDataLocation = mseloc + , modifyScheduledEventDataName = msename + , modifyScheduledEventDataPrivacyLevel = msepl + , modifyScheduledEventDataStartTime = msest + , modifyScheduledEventDataEndTime = mseet + , modifyScheduledEventDataDescription = msedesc + , modifyScheduledEventDataType = msetype + , modifyScheduledEventDataStatus = msestat + , modifyScheduledEventDataImage = mseimg + } + ) + +-- | An User that subscribed to a Scheduled Event +data ScheduledEventUser = ScheduledEventUser + { scheduledEventUserEvent :: ScheduledEventId + , scheduledEventUserUser :: User + , scheduledEventUserGuildMember :: Maybe GuildMember + } + +instance FromJSON ScheduledEventUser where + parseJSON = withObject + "ScheduledEventUser" + (\v -> + ScheduledEventUser + <$> v .: "guild_scheduled_event_id" + <*> v .: "user" + <*> v .:? "member" + ) diff --git a/deps/discord-haskell/src/Discord/Internal/Types/User.hs b/deps/discord-haskell/src/Discord/Internal/Types/User.hs new file mode 100644 index 0000000..b23d2f1 --- /dev/null +++ b/deps/discord-haskell/src/Discord/Internal/Types/User.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures pertaining to Discord User +module Discord.Internal.Types.User where + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as T +import Discord.Internal.Types.Prelude +import Data.Time (UTCTime) + +-- | Represents information about a user. +data User = User + { userId :: UserId -- ^ The user's id. + , userName :: T.Text -- ^ The user's username (not unique) + , userDiscrim :: Maybe T.Text -- ^ The user's 4-digit discord-tag. + , userGlobalName :: Maybe T.Text -- ^ The user's display name. + , userAvatar :: Maybe T.Text -- ^ The user's avatar hash. + , userIsBot :: Bool -- ^ User is an OAuth2 application. + , userIsWebhook :: Bool -- ^ User is a webhook. + , userIsSystem :: Maybe Bool -- ^ User is an official discord system user. + , userMfa :: Maybe Bool -- ^ User has two factor authentication enabled on the account. + , userBanner :: Maybe T.Text -- ^ User's banner hash + , userAccentColor :: Maybe Int -- ^ User's banner color + , userLocale :: Maybe T.Text -- ^ User's chosen language + , userVerified :: Maybe Bool -- ^ Whether the email has been verified. + , userEmail :: Maybe T.Text -- ^ The user's email. + , userFlags :: Maybe Integer -- ^ The user's flags. + , userPremiumType :: Maybe Integer -- ^ The user's premium type. + , userPublicFlags :: Maybe Integer -- ^ The user's public flags. + , userMember :: Maybe GuildMember -- ^ Some guild member info (message create/update) + } deriving (Show, Read, Eq, Ord) + +instance FromJSON User where + parseJSON = withObject "User" $ \o -> + User <$> o .: "id" + <*> o .: "username" + <*> o .:? "discriminator" -- possibly not there in the case of webhooks + <*> o .:? "global_name" + <*> o .:? "avatar" + <*> o .:? "bot" .!= False + <*> pure False -- webhook + <*> o .:? "system" + <*> o .:? "mfa_enabled" + <*> o .:? "banner" + <*> o .:? "accent_color" + <*> o .:? "locale" + <*> o .:? "verified" + <*> o .:? "email" + <*> o .:? "flags" + <*> o .:? "premium_type" + <*> o .:? "public_flags" + <*> o .:? "member" + +instance ToJSON User where + toJSON User{..} = objectFromMaybes + [ "id" .== userId + , "username" .== userName + , "discriminator" .=? userDiscrim + , "global_name" .=? userGlobalName + , "avatar" .=? userAvatar + , "bot" .== userIsBot + , "system" .=? userIsSystem + , "mfa_enabled" .=? userMfa + , "banner" .=? userBanner + , "accent_color" .=? userAccentColor + , "verified" .=? userVerified + , "email" .=? userEmail + , "flags" .=? userFlags + , "premium_type" .=? userPremiumType + , "public_flags" .=? userPublicFlags + , "member" .=? userPublicFlags + ] + +-- TODO: fully update webhook structure +data Webhook = Webhook + { webhookId :: WebhookId + , webhookToken :: Maybe WebhookToken + , webhookChannelId :: ChannelId + } deriving (Show, Read, Eq, Ord) + +instance FromJSON Webhook where + parseJSON = withObject "Webhook" $ \o -> + Webhook <$> o .: "id" + <*> o .:? "token" + <*> o .: "channel_id" + +-- | The connection object that the user has attached. +data ConnectionObject = ConnectionObject + { connectionObjectId :: Text -- ^ id of the connection account + , connectionObjectName :: Text -- ^ the username of the connection account + , connectionObjectType :: Text -- ^ the service of the connection (twitch, youtube) + , connectionObjectRevoked :: Bool -- ^ whether the connection is revoked + , connectionObjectIntegrations :: [IntegrationId] -- ^ List of server `IntegrationId` + , connectionObjectVerified :: Bool -- ^ whether the connection is verified + , connectionObjectFriendSyncOn :: Bool -- ^ whether friend sync is enabled for this connection + , connectionObjectShownInPresenceUpdates :: Bool -- ^ whether activities related to this connection will be shown in presence updates + , connectionObjectVisibleToOthers :: Bool -- ^ visibility of this connection + } deriving (Show, Read, Eq, Ord) + +instance FromJSON ConnectionObject where + parseJSON = withObject "ConnectionObject" $ \o -> do + integrations <- o .: "integrations" + ConnectionObject <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "revoked" + <*> mapM (.: "id") integrations + <*> o .: "verified" + <*> o .: "friend_sync" + <*> o .: "show_activity" + <*> ( (==) (1::Int) <$> o .: "visibility") + + +-- | Representation of a guild member. +data GuildMember = GuildMember + { memberUser :: Maybe User -- ^ User object - not included in message_create or update + , memberNick :: Maybe T.Text -- ^ User's guild nickname + , memberAvatar :: Maybe T.Text -- ^ User's guild avatar hash + , memberRoles :: [RoleId] -- ^ Array of role ids + , memberJoinedAt :: UTCTime -- ^ When the user joined the guild + , memberPremiumSince :: Maybe UTCTime -- ^ When the user started boosting the guild + , memberDeaf :: Bool -- ^ Whether the user is deafened + , memberMute :: Bool -- ^ Whether the user is muted + , memberPending :: Bool -- ^ Whether the user has passed the guild's membership screening + , memberPermissions :: Maybe T.Text -- ^ total permissions of the member + , memberTimeoutEnd :: Maybe UTCTime -- ^ when the user's timeout will expire and they can communicate again + } deriving (Show, Read, Eq, Ord) + +instance FromJSON GuildMember where + parseJSON = withObject "GuildMember" $ \o -> + GuildMember <$> o .:? "user" + <*> o .:? "nick" + <*> o .:? "avatar" + <*> o .: "roles" + <*> o .: "joined_at" + <*> o .:? "premium_since" + <*> o .: "deaf" + <*> o .: "mute" + <*> o .:? "pending" .!= False + <*> o .:? "permissions" + <*> o .:? "communication_disabled_until" + +instance ToJSON GuildMember where + toJSON GuildMember {..} = objectFromMaybes + [ "user" .=? memberUser + , "nick" .=? memberNick + , "avatar" .=? memberAvatar + , "roles" .== memberRoles + , "joined_at" .== memberJoinedAt + , "premium_since" .=? memberPremiumSince + , "deaf" .== memberDeaf + , "mute" .== memberMute + , "pending" .== memberPending + , "permissions" .=? memberPermissions + , "communication_disabled_until" .=? memberTimeoutEnd + ] diff --git a/deps/discord-haskell/src/Discord/Requests.hs b/deps/discord-haskell/src/Discord/Requests.hs new file mode 100644 index 0000000..6f2127e --- /dev/null +++ b/deps/discord-haskell/src/Discord/Requests.hs @@ -0,0 +1,23 @@ +module Discord.Requests + ( module Discord.Internal.Rest.Channel + , module Discord.Internal.Rest.Emoji + , module Discord.Internal.Rest.Guild + , module Discord.Internal.Rest.Invite + , module Discord.Internal.Rest.User + , module Discord.Internal.Rest.Voice + , module Discord.Internal.Rest.Webhook + , module Discord.Internal.Rest.ApplicationCommands + , module Discord.Internal.Rest.Interactions + , module Discord.Internal.Rest.ScheduledEvents + ) where + +import Discord.Internal.Rest.Channel +import Discord.Internal.Rest.Emoji +import Discord.Internal.Rest.Guild +import Discord.Internal.Rest.Invite +import Discord.Internal.Rest.User +import Discord.Internal.Rest.Voice +import Discord.Internal.Rest.Webhook +import Discord.Internal.Rest.ApplicationCommands +import Discord.Internal.Rest.Interactions +import Discord.Internal.Rest.ScheduledEvents diff --git a/deps/discord-haskell/src/Discord/Types.hs b/deps/discord-haskell/src/Discord/Types.hs new file mode 100644 index 0000000..d14027a --- /dev/null +++ b/deps/discord-haskell/src/Discord/Types.hs @@ -0,0 +1,16 @@ +-- | Re-export user-visible types +module Discord.Types + ( module Discord.Internal.Types + ) where + +import Discord.Internal.Types hiding + ( GatewaySendableInternal(..) + , GatewayReceivable(..) + , EventInternalParse(..) + , InternalDiscordEnum(..) + , Base64Image(..) + + , colorToInternal + , convertToRGB + , hexToRGB + ) |