diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,112 +1,38 @@ # discord-haskell [![Build Status](https://travis-ci.org/aquarial/discord-haskell.png?branch=master)](https://travis-ci.org/aquarial/discord-haskell) -Please refer to `Getting Started` and `Notes` when -relevant. A few minutes of reading can save you -hours of debugging. - -Recent change: `master` branch has the potentially broken, most -recent commits, `stable` has the most recent working version. -Pull requests are automatically made against `master` and it's -nice to merge pull requests to test them. - -## Getting Started - -1 Create an application at the Developer Portal: -. - -2 Add a 'Bot User' using the settings pane on the left. Take -note of `CLIENT ID` on this page. - -3 Use the BOT PERMISSIONS tab to compute a Permissions Int to use for step 3 - -3 Invite the bot to a server filling in the `` below. -Client ID and Permissions come from previous steps. -`https://discordapp.com/oauth2/authorize?client_id=&scope=bot&permissions=` - -4 To send `CreateMessage` events with restCall, you must connect to the gateway at least once. Try running `examples/gateway.hs` with your token to satisfy this. -[This is a Discord requirement.](https://discordapp.com/developers/docs/resources/channel#create-message) +## Go to the [Wiki](https://github.com/aquarial/discord-haskell/wiki) for more information -5 Look at the examples to get an idea of how the library is used. -[examples/gateway.hs](./examples/gateway.hs), -[examples/rest.hs](./examples/rest.hs), -[examples/cache.hs](./examples/cache.hs), and -[examples/ping-pong.hs](./examples/ping-pong.hs) +```haskell +{-# LANGUAGE OverloadedStrings #-} -- allows "string literals" to be Text -6 Understand what's available to the bot. Rest API calls can modify -[Channels](https://discordapp.com/developers/docs/resources/channel#get-channel), -[Emoji](https://discordapp.com/developers/docs/resources/emoji#list-guild-emojis), -[Guilds](https://discordapp.com/developers/docs/resources/guild#get-guild), -etc. Most endpoints are covered with very similar names. `List Guild Emojis` -becomes `ListGuildEmojis`. You can use `:info` in `ghci` on type constructors to -explore the ADTs. +import Control.Monad (when) +import Data.Text (isPrefixOf, toLower, Text) +import Control.Concurrent (threadDelay) +import qualified Data.Text.IO as TIO -[Gateway Events](https://discordapp.com/developers/docs/topics/gateway#commands-and-events-gateway-events) -provide the other source of info, using `nextEvent` and `sendCommand`. Use `:info` to explore `Event` and `GatewaySendable` ADTs. +import Discord +import Discord.Types +import qualified Discord.Requests as R -7 Add this library to your dependencies. discord-haskell is on hackage, -open an issue if the dependencies are too strict and you can't -add it to your project.. You can also use the github repo. +-- | Replies "pong" to every message that starts with "ping" +pingpongExample :: IO () +pingpongExample = do userFacingError <- runDiscord $ def + { discordToken = "Bot ZZZZZZZZZZZZZZZZZZZ" + , discordOnEvent = eventHandler } + TIO.putStrLn userFacingError -``` -# in stack.yaml (if using stack) -resolver: lts-12.10 -extra-deps: -- git: git@github.com:aquarial/discord-haskell.git - commit: - extra-dep: true +eventHandler :: DiscordHandle -> Event -> IO () +eventHandler dis event = case event of + MessageCreate m -> when (not (fromBot m) && isPing (messageText m)) $ do + _ <- restCall dis (R.CreateReaction (messageChannel m, messageId m) "eyes") + threadDelay (4 * 10^6) + _ <- restCall dis (R.CreateMessage (messageChannel m) "Pong!") + pure () + _ -> pure () -# in project.cabal - build-depends: base - , discord-haskell +fromBot :: Message -> Bool +fromBot m = userIsBot (messageAuthor m) +isPing :: Text -> Bool +isPing = ("ping" `isPrefixOf`) . toLower ``` - -## Notes - -`loginRest` allows `restCall`. `loginRestGateway` allows `restCall`, -`nextEvent`, `sendCommand`, and `readCache`. **Use `loginRest` if you don't need the -gateway.** - -Use `Control.Exception.finally` with `stopDiscord` to safely -kill background threads when running examples in ghci -(otherwise exit ghci and reopen to kill threads). - -The examples will work on the `stable` branch. The `master` branch -has the most recent (potentially) breaking changes. - -To get the format to use for Emoji, type `\:emoji:` into -a discord chat. You should copy-paste that into the request. This -can be a bit finicky. The equivalent of `:thumbsup::skin-tone-3:` -is `"👍\127997"` for example, and a custom emoji will look -like `` or `name:id_number`. - -## Debugging - -If something goes wrong with the library please open an issue. It is helpful, -but not always necessary, to attach a log of what's going on when the library -crashes. - -Use `loginRestGatewayWithLog :: Auth -> String -> IO (stuff)` to write the events to -a file. Remember to remove sensitive information before posting. - -## History - -This library was originally forked from -[discord.hs](https://github.com/jano017/Discord.hs). -After rewriting the gateway/rest loops and extending the types -I think it makes more sense to present this library as -separate from the source. The APIs are not compatible. - -## TO DO - -In roughly the order I'm working on them: - -- Finish REST request ADT. Search for `-- todo` pattern -- Add data types for -[permissions](https://discordapp.com/developers/docs/topics/permissions) and -[presences](https://discordapp.com/developers/docs/topics/gateway#presence-update) -- Update channel types (fill out guildcategory) -- Modify cache with Events -- Add gateway ToJSON for events -- Update comments on ADT types - diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -4,6 +4,13 @@ ## master +Going through some major updates to the library. Expect types to change and things to break. + +Compare the [old ping-pong](https://github.com/aquarial/discord-haskell/blob/20f7f8556823a754c76d01484118a5abf336530b/examples/ping-pong.hs) +to the [new ping-pong](https://github.com/aquarial/discord-haskell/blob/7eaa6ca068f945603de7f43f6f270c2dbecd3c85/examples/ping-pong.hs) + +Added a few rest ADT types + ## 0.8.4 [marcotoniut](https://github.com/aquarial/discord-haskell/pull/18) Improved changed Embed ADT to have optional fields, and improved two field names diff --git a/discord-haskell.cabal b/discord-haskell.cabal --- a/discord-haskell.cabal +++ b/discord-haskell.cabal @@ -1,12 +1,12 @@ cabal-version: 2.0 name: discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs -version: 0.8.4 +version: 1.0.0 description: Functions and data types to write discord bots. Official discord docs . . - See the project readme for quickstart notes - + See the project wiki for quickstart notes + synopsis: Write bots for Discord in Haskell homepage: https://github.com/aquarial/discord-haskell bug-reports: https://github.com/aquarial/discord-haskell/issues @@ -24,6 +24,16 @@ type: git location: https://github.com/aquarial/discord-haskell.git +executable ping-pong + main-is: examples/ping-pong.hs + default-language: Haskell2010 + ghc-options: -Wall + -fno-warn-type-defaults + -threaded + build-depends: base + , text + , discord-haskell + library ghc-options: -Wall -fno-warn-type-defaults @@ -31,23 +41,28 @@ default-language: Haskell2010 -- extensions: exposed-modules: Discord - , Discord.Gateway - , Discord.Gateway.Cache - , Discord.Gateway.EventLoop - , Discord.Rest - , Discord.Rest.Prelude - , Discord.Rest.HTTP - , Discord.Rest.Invite - , Discord.Rest.Emoji - , Discord.Rest.User - , Discord.Rest.Guild - , Discord.Rest.Channel , Discord.Types - , Discord.Types.Prelude - , Discord.Types.Channel - , Discord.Types.Events - , Discord.Types.Gateway - , Discord.Types.Guild + , Discord.Handle + , Discord.Requests + , Discord.Internal.Gateway + , Discord.Internal.Gateway.Cache + , Discord.Internal.Gateway.EventLoop + , Discord.Internal.Rest + , Discord.Internal.Rest.Prelude + , Discord.Internal.Rest.HTTP + , Discord.Internal.Rest.Invite + , Discord.Internal.Rest.Emoji + , Discord.Internal.Rest.User + , Discord.Internal.Rest.Guild + , Discord.Internal.Rest.Channel + , Discord.Internal.Rest.Voice + , Discord.Internal.Rest.Webhook + , Discord.Internal.Types + , Discord.Internal.Types.Prelude + , Discord.Internal.Types.Channel + , Discord.Internal.Types.Events + , Discord.Internal.Types.Gateway + , Discord.Internal.Types.Guild build-depends: base >=4 && <5 , aeson >=1.3.1.1 && <1.5 @@ -56,6 +71,7 @@ , base64-bytestring >=1.0.0.1 && <1.1 , containers >=0.5.11.0 && <0.7 , data-default >=0.7.1.1 && <0.8 + , emoji == 0.1.0.2 , http-client >=0.5.13.1 && <0.6 , iso8601-time >=0.1.5 && <0.2 , MonadRandom >=0.5.1.1 && <0.6 diff --git a/examples/ping-pong.hs b/examples/ping-pong.hs new file mode 100644 --- /dev/null +++ b/examples/ping-pong.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} -- allows "strings" to be Data.Text + +import Control.Monad (when, forM_) +import Control.Concurrent (threadDelay) +import Data.Char (toLower) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Discord +import Discord.Types +import qualified Discord.Requests as R + +main :: IO () +main = pingpongExample + +-- | Replies "pong" to every message that starts with "ping" +pingpongExample :: IO () +pingpongExample = do + tok <- TIO.readFile "./examples/auth-token.secret" + + -- open ghci and run [[ def :: RunDiscordOpts ]] to see default Opts + t <- runDiscord $ def { discordToken = tok + , discordOnStart = startHandler + , discordOnEnd = putStrLn "Ended" + , discordOnEvent = eventHandler + , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" + } + threadDelay (1 `div` 10 * 10^6) + TIO.putStrLn t + +-- If a handler throws an exception, discord-haskell will gracefully shutdown +startHandler :: DiscordHandle -> IO () +startHandler dis = do + Right partialGuilds <- restCall dis R.GetCurrentUserGuilds + + forM_ partialGuilds $ \pg -> do + Right guild <- restCall dis $ R.GetGuild (partialGuildId pg) + Right chans <- restCall dis $ R.GetGuildChannels (guildId guild) + case filter isTextChannel chans of + (c:_) -> do _ <- restCall dis $ R.CreateMessage (channelId c) "Hello! I will reply to pings with pongs" + pure () + _ -> pure () + +eventHandler :: DiscordHandle -> Event -> IO () +eventHandler dis event = case event of + MessageCreate m -> when (not (fromBot m) && isPing (messageText m)) $ do + _ <- restCall dis (R.CreateReaction (messageChannel m, messageId m) "eyes") + threadDelay (4 * 10^6) + _ <- restCall dis (R.CreateMessage (messageChannel m) "Pong!") + pure () + _ -> pure () + +isTextChannel :: Channel -> Bool +isTextChannel (ChannelText {}) = True +isTextChannel _ = False + +fromBot :: Message -> Bool +fromBot m = userIsBot (messageAuthor m) + +isPing :: T.Text -> Bool +isPing = ("ping" `T.isPrefixOf`) . T.map toLower diff --git a/src/Discord.hs b/src/Discord.hs --- a/src/Discord.hs +++ b/src/Discord.hs @@ -1,127 +1,172 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Discord - ( module Discord.Types - , module Discord.Rest.Channel - , module Discord.Rest.Guild - , module Discord.Rest.User - , module Discord.Rest.Invite - , module Discord.Rest.Emoji - , module Discord.Rest.Voice - , module Discord.Rest.Webhook - , Cache(..) - , Gateway(..) - , RestChan(..) - , RestCallException(..) - , GatewayException(..) - , Request(..) - , ThreadIdType(..) + ( runDiscord , restCall - , nextEvent , sendCommand , readCache , stopDiscord - , loginRest - , loginRestGateway - , loginRestGatewayWithLog + + , DiscordHandle + , Cache(..) + , RestCallErrorCode(..) + , RunDiscordOpts(..) + , FromJSON + , def ) where import Prelude hiding (log) -import Control.Monad (forever) +import Control.Monad (forever, void) import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Concurrent.Async (race) +import Control.Exception.Safe (try, finally, IOException, SomeException) import Control.Concurrent.Chan import Control.Concurrent.MVar -import Data.Monoid ((<>)) -import Data.Aeson +import Data.Aeson (FromJSON) +import Data.Default (Default, def) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE -import Discord.Rest -import Discord.Rest.Channel -import Discord.Rest.Guild -import Discord.Rest.User -import Discord.Rest.Invite -import Discord.Rest.Emoji -import Discord.Rest.Voice -import Discord.Rest.Webhook -import Discord.Types -import Discord.Gateway -import Discord.Gateway.Cache +import Discord.Handle +import Discord.Internal.Rest +import Discord.Internal.Rest.User (UserRequest(GetCurrentUser)) +import Discord.Internal.Gateway --- | Thread Ids marked by what type they are -data ThreadIdType = ThreadRest ThreadId - | ThreadGateway ThreadId - | ThreadLogger ThreadId --- | As opposed to a Gateway object -data NotLoggedIntoGateway = NotLoggedIntoGateway +data RunDiscordOpts = RunDiscordOpts + { discordToken :: T.Text + , discordOnStart :: DiscordHandle -> IO () + , discordOnEnd :: IO () + , discordOnEvent :: DiscordHandle -> Event -> IO () + , discordOnLog :: T.Text -> IO () + , discordForkThreadForEvents :: Bool + } --- | Start HTTP rest handler background threads -loginRest :: Auth -> IO (RestChan, NotLoggedIntoGateway, [ThreadIdType]) -loginRest auth = do - log <- newChan - logId <- forkIO (logger log False "") - (restHandler, restId) <- createHandler auth log - pure (restHandler, NotLoggedIntoGateway, [ ThreadLogger logId - , ThreadRest restId - ]) +instance Default RunDiscordOpts where + def = RunDiscordOpts { discordToken = "" + , discordOnStart = \_ -> pure () + , discordOnEnd = pure () + , discordOnEvent = \_ _-> pure () + , discordOnLog = \_ -> pure () + , discordForkThreadForEvents = True + } --- | Start HTTP rest handler and gateway background threads -loginRestGateway :: Auth -> IO (RestChan, Gateway, [ThreadIdType]) -loginRestGateway auth = do +runDiscord :: RunDiscordOpts -> IO T.Text +runDiscord opts = do log <- newChan - logId <- forkIO (logger log False "") - (restHandler, restId) <- createHandler auth log - (gate, gateId) <- startGatewayThread auth log - pure (restHandler, gate, [ ThreadLogger logId - , ThreadRest restId - , ThreadGateway gateId - ]) + logId <- startLogger (discordOnLog opts) log + (cache, cacheId) <- startCacheThread log + (rest, restId) <- startRestThread (Auth (discordToken opts)) log + (gate, gateId) <- startGatewayThread (Auth (discordToken opts)) cache log --- | Start HTTP rest handler and gateway background threads -loginRestGatewayWithLog :: Auth -> String -> IO (RestChan, Gateway, [ThreadIdType]) -loginRestGatewayWithLog auth path = do - log <- newChan - logId <- forkIO (logger log True path) - (restHandler, restId) <- createHandler auth log - (gate, gateId) <- startGatewayThread auth log - pure (restHandler, gate, [ ThreadLogger logId - , ThreadRest restId - , ThreadGateway gateId - ]) + libE <- newEmptyMVar --- | Execute one http request and get a response -restCall :: (FromJSON a, Request (r a)) => - (RestChan, y, z) -> r a -> IO (Either RestCallException a) -restCall (r,_,_) = writeRestCall r + let handle = DiscordHandle { discordHandleRestChan = rest + , discordHandleGateway = gate + , discordHandleCache = cache + , discordHandleLog = log + , discordHandleLibraryError = libE + , discordHandleThreads = + [ DiscordHandleThreadIdLogger logId + , DiscordHandleThreadIdRest restId + , DiscordHandleThreadIdCache cacheId + , DiscordHandleThreadIdGateway gateId + ] + } --- | Block until the gateway produces another event. Once an exception is returned, --- only return that exception -nextEvent :: (x, Gateway, z) -> IO (Either GatewayException Event) -nextEvent (_,g,_) = readChan (_events g) + finally (runDiscordLoop opts handle) + (discordOnEnd opts >> stopDiscord handle) +runDiscordLoop :: RunDiscordOpts -> DiscordHandle -> IO T.Text +runDiscordLoop opts handle = do + resp <- 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 <- try (discordOnStart opts handle) + case me of + Left (e :: SomeException) -> libError ("Your code threw 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 (fst (discordHandleGateway handle))) + case next of + Left err -> libError err + Right (Right event) -> do + let action = if discordForkThreadForEvents opts then void . forkIO + else id + action $ do me <- try (discordOnEvent opts handle event) + case me of + Left (e :: SomeException) -> writeChan (discordHandleLog handle) + ("Your code threw an exception:\n\n" <> T.pack (show e)) + Right _ -> pure () + loop + Right (Left err) -> libError (T.pack (show err)) + + +data RestCallErrorCode = RestCallErrorCode Int T.Text T.Text + deriving (Show, Eq, Ord) + +-- | Execute one http request and get a response +restCall :: (FromJSON a, Request (r a)) => DiscordHandle -> r a -> IO (Either RestCallErrorCode a) +restCall h r = do empty <- isEmptyMVar (discordHandleLibraryError h) + if not empty + then pure (Left (RestCallErrorCode 400 "Library Stopped Working" "")) + else do + resp <- writeRestCall (discordHandleRestChan h) r + case resp of + Right x -> pure (Right x) + Left (RestCallInternalErrorCode c e1 e2) -> + pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2))) + Left (RestCallInternalHttpException _) -> + threadDelay (10 * 10^6) >> restCall h r + Left (RestCallInternalNoParse err dat) -> do + let formaterr = T.pack ("Parse Exception " <> err <> " for " <> show dat) + writeChan (discordHandleLog h) formaterr + pure (Left (RestCallErrorCode 400 "Library Stopped Working" formaterr)) + -- | Send a GatewaySendable, but not Heartbeat, Identify, or Resume -sendCommand :: (x, Gateway, z) -> GatewaySendable -> IO () -sendCommand (_,g,_) e = case e of - Heartbeat _ -> pure () - Identify _ _ _ _ -> pure () - Resume _ _ _ -> pure () - _ -> writeChan (_gatewayCommands g) e +sendCommand :: DiscordHandle -> GatewaySendable -> IO () +sendCommand h e = case e of + Heartbeat _ -> pure () + Identify {} -> pure () + Resume {} -> pure () + _ -> writeChan (snd (discordHandleGateway h)) e -- | Access the current state of the gateway cache -readCache :: (RestChan, Gateway, z) -> IO (Either GatewayException Cache) -readCache (_,g,_) = readMVar (_cache g) +readCache :: DiscordHandle -> IO Cache +readCache h = do merr <- readMVar (snd (discordHandleCache h)) + case merr of + Left (c, _) -> pure c + Right c -> pure c + -- | Stop all the background threads -stopDiscord :: (x, y, [ThreadIdType]) -> IO () -stopDiscord (_,_,is) = threadDelay (10^6 `div` 10) >> mapM_ (killThread . toId) is +stopDiscord :: DiscordHandle -> IO () +stopDiscord h = do _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed" + threadDelay (10^6 `div` 10) + mapM_ (killThread . toId) (discordHandleThreads h) where toId t = case t of - ThreadRest a -> a - ThreadGateway a -> a - ThreadLogger a -> a + DiscordHandleThreadIdRest a -> a + DiscordHandleThreadIdGateway a -> a + DiscordHandleThreadIdCache a -> a + DiscordHandleThreadIdLogger a -> a --- | Add anything from the Chan to the log file, forever -logger :: Chan String -> Bool -> String -> IO () -logger log False _ = forever $ readChan log >>= \_ -> pure () -logger log True f = forever $ do - x <- readChan log - let line = x <> "\n\n" - appendFile f line +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 () + diff --git a/src/Discord/Gateway.hs b/src/Discord/Gateway.hs deleted file mode 100644 --- a/src/Discord/Gateway.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# OPTIONS_HADDOCK prune, not-home #-} - --- | Provides a rather raw interface to the websocket events --- through a real-time Chan -module Discord.Gateway - ( Gateway(..) - , GatewayException(..) - , startGatewayThread - , module Discord.Types - ) where - -import Prelude hiding (log) -import Control.Concurrent.Chan (newChan, dupChan, Chan) -import Control.Concurrent (forkIO, ThreadId, MVar) - -import Discord.Types (Auth, Event, GatewaySendable) -import Discord.Gateway.EventLoop (connectionLoop, GatewayException(..)) -import Discord.Gateway.Cache - --- | Concurrency primitives that make up the gateway. Build a higher --- level interface over these -data Gateway = Gateway - { _events :: Chan (Either GatewayException Event) - , _cache :: MVar (Either GatewayException Cache) - , _gatewayCommands :: Chan GatewaySendable - } - --- | Create a Chan for websockets. This creates a thread that --- writes all the received Events to the Chan -startGatewayThread :: Auth -> Chan String -> IO (Gateway, ThreadId) -startGatewayThread auth log = do - eventsWrite <- newChan - eventsCache <- dupChan eventsWrite - sends <- newChan - cache <- emptyCache :: IO (MVar (Either GatewayException Cache)) - tid <- forkIO $ connectionLoop auth eventsWrite sends log - cacheAddEventLoopFork cache eventsCache log - pure (Gateway eventsWrite cache sends, tid) - - - diff --git a/src/Discord/Gateway/Cache.hs b/src/Discord/Gateway/Cache.hs deleted file mode 100644 --- a/src/Discord/Gateway/Cache.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_HADDOCK prune, not-home #-} - --- | Query info about connected Guilds and Channels -module Discord.Gateway.Cache where - -import Prelude hiding (log) -import Data.Monoid ((<>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Control.Concurrent.Chan -import qualified Data.Map.Strict as M - -import Discord.Types -import Discord.Gateway.EventLoop - -data Cache = Cache - { _currentUser :: User - , _dmChannels :: M.Map ChannelId Channel - , _guilds :: M.Map GuildId (Guild, GuildInfo) - , _channels :: M.Map ChannelId Channel - } deriving (Show) - -emptyCache :: IO (MVar (Either GatewayException Cache)) -emptyCache = newEmptyMVar - -cacheAddEventLoopFork :: MVar (Either GatewayException Cache) -> Chan (Either GatewayException Event) -> Chan String -> IO () -cacheAddEventLoopFork cache eventChan log = do - ready <- readChan eventChan - case ready of - Right (Ready _ user dmChannels _unavailableGuilds _) -> do - let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels) - putMVar cache (Right (Cache user dmChans M.empty M.empty)) - _ <- forkIO loop - pure () - Right r -> do - writeChan log ("cache - expected Ready event, but got " <> show r) - cacheAddEventLoopFork cache eventChan log - Left e -> do - writeChan log "cache - gateway exception, stopping cache" - putMVar cache (Left e) - where - loop :: IO () - loop = do - eventOrExcept <- readChan eventChan - minfo <- takeMVar cache - case (eventOrExcept, minfo) of - (_, Left _) -> pure () -- never happen bc we stop loop once cache has an exception - (Left exception, _) -> do putMVar cache (Left exception) - -- stop cache loop - (Right event, Right info) -> do - putMVar cache (Right (adjustCache info event)) - loop - -adjustCache :: Cache -> Event -> Cache -adjustCache minfo event = case event of - --ChannelCreate Channel - --ChannelUpdate Channel - --ChannelDelete Channel - GuildCreate guild info -> - let newChans = map (setChanGuildID (guildId guild)) $ guildChannels info - g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (_guilds minfo) - c = M.unionWith (\a _ -> a) - (M.fromList [ (channelId ch, ch) | ch <- newChans ]) - (_channels minfo) - in minfo { _guilds = g, _channels = c } - --GuildUpdate guild -> do - -- let g = M.insert (guildId guild) guild (_guilds minfo) - -- m2 = minfo { _guilds = g } - -- putMVar cache m2 - --GuildDelete guild -> do - -- let g = M.delete (guildId guild) (_guilds minfo) - -- c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (_channels minfo) - -- m2 = minfo { _guilds = g, _channels = c } - -- putMVar cache m2 - _ -> minfo - -setChanGuildID :: GuildId -> Channel -> Channel -setChanGuildID s c = if channelIsInGuild c - then c { channelGuild = s } - else c diff --git a/src/Discord/Gateway/EventLoop.hs b/src/Discord/Gateway/EventLoop.hs deleted file mode 100644 --- a/src/Discord/Gateway/EventLoop.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_HADDOCK prune, not-home #-} - --- | Provides logic code for interacting with the Discord websocket --- gateway. Realistically, this is probably lower level than most --- people will need -module Discord.Gateway.EventLoop where - -import Prelude hiding (log) - -import Control.Monad (forever) -import Control.Monad.Random (getRandomR) -import Control.Concurrent.Async (race) -import Control.Concurrent.Chan -import Control.Exception.Safe (try, finally, handle, SomeException) -import Control.Concurrent (threadDelay, killThread, forkIO) -import Data.Monoid ((<>)) -import Data.IORef -import Data.Aeson (eitherDecode, encode) -import qualified Data.Text as T -import qualified Data.ByteString.Lazy.Char8 as QL - -import Wuss (runSecureClient) -import Network.WebSockets (ConnectionException(..), Connection, - receiveData, sendTextData) -import GHC.IO.Exception (IOError) - -import Discord.Types - -data GatewayException = GatewayExceptionCouldNotConnect T.Text - | GatewayExceptionEventParseError String T.Text - | GatewayExceptionUnexpected GatewayReceivable T.Text - | GatewayExceptionConnection ConnectionException T.Text - deriving (Show) - -data ConnLoopState = ConnStart - | ConnClosed - | ConnReconnect Auth String Integer - deriving Show - --- | Securely run a connection IO action. Send a close on exception -connect :: (Connection -> IO a) -> IO a -connect = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" - -connectionLoop :: Auth -> Chan (Either GatewayException Event) -> Chan GatewaySendable - -> Chan String -> IO () -connectionLoop auth events userSend log = loop ConnStart 0 - where - loop :: ConnLoopState -> Int -> IO () - loop s retries = do - writeChan log ("gateway - connection loop state " <> show s) - case s of - (ConnClosed) -> pure () - (ConnStart) -> do - -- only try-catch an IO Error - next <- try $ connect $ \conn -> do - msg <- getPayload conn log - case msg of - Right (Hello interval) -> do - sendTextData conn (encode (Identify auth False 50 (0, 1))) - msg2 <- getPayload conn log - case msg2 of - Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do - writeChan events (Right r) - startEventStream (ConnData conn seshID auth events) interval 0 userSend log - Right m -> do writeChan events (Left (GatewayExceptionUnexpected m - "Response to Identify must be Ready")) - pure ConnClosed - Left ce -> do writeChan events (Left (GatewayExceptionConnection ce - "Response to Identify")) - pure ConnClosed - Right m -> do writeChan log ("gateway - first message must be hello: " <> show msg) - writeChan events (Left (GatewayExceptionUnexpected m - "Response to connecting must be hello")) - pure ConnClosed - Left ce -> do writeChan events (Left (GatewayExceptionConnection ce - "Response to connecting")) - pure ConnClosed - case next :: Either IOError ConnLoopState of - Left _ -> do writeChan events (Left (GatewayExceptionCouldNotConnect - "IOError in gateway Connection")) - loop ConnClosed 0 - Right n -> loop n 0 - - (ConnReconnect (Auth tok) seshID seqID) -> do - next <- try $ connect $ \conn -> do - sendTextData conn (encode (Resume tok seshID seqID)) - eitherPayload <- getPayload conn log - case eitherPayload of - Right (Hello interval) -> - startEventStream (ConnData conn seshID auth events) interval seqID userSend log - Right (InvalidSession retry) -> do - t <- getRandomR (1,5) - threadDelay (t * 10^6) - pure $ if retry - then ConnReconnect (Auth tok) seshID seqID - else ConnStart - Right payload -> do - writeChan events (Left (GatewayExceptionUnexpected payload - "Response to Resume must be Hello/Invalid Session")) - pure ConnClosed - Left e -> do - writeChan events (Left (GatewayExceptionConnection e - "Could not ConnReconnect")) - pure ConnClosed - case next :: Either SomeException ConnLoopState of - Left _ -> if (retries < 5) - then do t <- getRandomR (3,10) - threadDelay (t * 10^6) - loop (ConnReconnect (Auth tok) seshID seqID) (retries + 1) - else do writeChan events (Left (GatewayExceptionCouldNotConnect - "Too many retries failed")) - loop ConnClosed 0 - Right n -> loop n 0 - - -getPayloadTimeout :: Connection -> Int -> Chan String -> IO (Either ConnectionException GatewayReceivable) -getPayloadTimeout conn interval log = do - res <- race (threadDelay ((interval * 1000 * 3) `div` 2)) - (getPayload conn log) - case res of - Left () -> pure (Right Reconnect) - Right other -> pure other - -getPayload :: Connection -> Chan String -> IO (Either ConnectionException GatewayReceivable) -getPayload conn log = try $ do - msg' <- receiveData conn - writeChan log ("gateway - received " <> QL.unpack msg') - case eitherDecode msg' of - Right msg -> return msg - Left err -> do writeChan log ("gateway - received parse Error - " <> err) - return (ParseError err) - -heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> Chan String -> IO () -heartbeat send interval seqKey log = do - threadDelay (1 * 10^6) - writeChan log "gateway - starting heartbeat" - forever $ do - num <- readIORef seqKey - writeChan send (Heartbeat num) - threadDelay (interval * 1000) - -setSequence :: IORef Integer -> Integer -> IO () -setSequence key i = writeIORef key i - --- | What we need to start an event stream -data ConnectionData = ConnData { connection :: Connection - , connSessionID :: String - , connAuth :: Auth - , connChan :: Chan (Either GatewayException Event) - } - -startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> Chan String -> IO ConnLoopState -startEventStream conndata interval seqN userSend log = do - seqKey <- newIORef seqN - let err :: SomeException -> IO ConnLoopState - err e = do writeChan log ("gateway - eventStream error: " <> show e) - ConnReconnect (connAuth conndata) (connSessionID conndata) <$> readIORef seqKey - handle err $ do - gateSends <- newChan - sendsId <- forkIO $ sendableLoop (connection conndata) (Sendables userSend gateSends) - heart <- forkIO $ heartbeat gateSends interval seqKey log - - finally (eventStream conndata seqKey interval gateSends log) - (killThread heart >> killThread sendsId) - - -eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable - -> Chan String -> IO ConnLoopState -eventStream (ConnData conn seshID auth eventChan) seqKey interval send log = loop - where - loop :: IO ConnLoopState - loop = do - eitherPayload <- getPayloadTimeout conn interval log - case eitherPayload :: Either ConnectionException GatewayReceivable of - Left (CloseRequest code str) -> case code of - -- see Discord and MDN documentation on gateway close event codes - 1000 -> ConnReconnect auth seshID <$> readIORef seqKey - 1001 -> ConnReconnect auth seshID <$> readIORef seqKey - 4000 -> ConnReconnect auth seshID <$> readIORef seqKey - 4006 -> pure ConnStart - 4007 -> ConnReconnect auth seshID <$> readIORef seqKey - 4014 -> ConnReconnect auth seshID <$> readIORef seqKey - _ -> do writeChan eventChan (Left (GatewayExceptionConnection (CloseRequest code str) - "Normal event loop close request")) - pure ConnClosed - Left _ -> ConnReconnect auth seshID <$> readIORef seqKey - Right (Dispatch event sq) -> do setSequence seqKey sq - writeChan eventChan (Right event) - loop - Right (HeartbeatRequest sq) -> do setSequence seqKey sq - writeChan send (Heartbeat sq) - loop - Right (Reconnect) -> ConnReconnect auth seshID <$> readIORef seqKey - Right (InvalidSession retry) -> if retry - then ConnReconnect auth seshID <$> readIORef seqKey - else pure ConnStart - Right (HeartbeatAck) -> loop - Right (Hello e) -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello e) - "Normal event loop")) - pure ConnClosed - Right (ParseError e) -> do writeChan eventChan (Left (GatewayExceptionEventParseError e - "Normal event loop")) - pure ConnClosed - -data Sendables = Sendables { -- | Things the user wants to send. Doesn't reset on reconnect - userSends :: Chan GatewaySendable -- ^ Things the user wants to send - -- | Things the library needs to send. Resets to empty on reconnect - , gatewaySends :: Chan GatewaySendable - } - -sendableLoop :: Connection -> Sendables -> IO () -sendableLoop conn sends = forever $ do - -- send a ~120 events a min by delaying - threadDelay (round (10^6 * (62 / 120))) - let e :: Either GatewaySendable GatewaySendable -> GatewaySendable - e = either id id - payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends)) - sendTextData conn (encode payload) diff --git a/src/Discord/Handle.hs b/src/Discord/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Handle.hs @@ -0,0 +1,25 @@ +module Discord.Handle + ( DiscordHandle(..) + , DiscordHandleThreadId(..) + ) where + +import Control.Concurrent (ThreadId, Chan, MVar) +import qualified Data.Text as T + +import Discord.Internal.Rest (DiscordHandleRestChan) +import Discord.Internal.Gateway (DiscordHandleGateway, DiscordHandleCache) + +-- | Thread Ids marked by what type they are +data DiscordHandleThreadId = DiscordHandleThreadIdRest ThreadId + | DiscordHandleThreadIdCache ThreadId + | DiscordHandleThreadIdLogger ThreadId + | DiscordHandleThreadIdGateway ThreadId + +data DiscordHandle = DiscordHandle + { discordHandleRestChan :: DiscordHandleRestChan + , discordHandleGateway :: DiscordHandleGateway + , discordHandleCache :: DiscordHandleCache + , discordHandleThreads :: [DiscordHandleThreadId] + , discordHandleLog :: Chan T.Text + , discordHandleLibraryError :: MVar T.Text + } diff --git a/src/Discord/Internal/Gateway.hs b/src/Discord/Internal/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Gateway.hs @@ -0,0 +1,39 @@ +-- | Provides a rather raw interface to the websocket events +-- through a real-time Chan +module Discord.Internal.Gateway + ( DiscordHandleGateway + , DiscordHandleCache + , 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 qualified Data.Text as T + +import Discord.Internal.Types (Auth, Event, GatewaySendable) +import Discord.Internal.Gateway.EventLoop (connectionLoop, DiscordHandleGateway, GatewayException(..)) +import Discord.Internal.Gateway.Cache (cacheLoop, Cache(..), DiscordHandleCache) + +startCacheThread :: Chan T.Text -> IO (DiscordHandleCache, ThreadId) +startCacheThread log = do + events <- newChan :: IO (Chan (Either GatewayException Event)) + cache <- newEmptyMVar :: IO (MVar (Either (Cache, GatewayException) Cache)) + tid <- forkIO $ cacheLoop (events, cache) log + pure ((events, cache), tid) + +-- | Create a Chan for websockets. This creates a thread that +-- writes all the received Events to the Chan +startGatewayThread :: Auth -> DiscordHandleCache -> Chan T.Text -> IO (DiscordHandleGateway, ThreadId) +startGatewayThread auth (_events, _) log = do + events <- dupChan _events + sends <- newChan + tid <- forkIO $ connectionLoop auth (events, sends) log + pure ((events, sends), tid) + + + diff --git a/src/Discord/Internal/Gateway/Cache.hs b/src/Discord/Internal/Gateway/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Gateway/Cache.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Query info about connected Guilds and Channels +module Discord.Internal.Gateway.Cache where + +import Prelude hiding (log) +import Data.Monoid ((<>)) +import Control.Monad (forever) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +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 + { _currentUser :: User + , _dmChannels :: M.Map ChannelId Channel + , _guilds :: M.Map GuildId (Guild, GuildInfo) + , _channels :: M.Map ChannelId Channel + } deriving (Show) + +type DiscordHandleCache = (Chan (Either GatewayException Event), MVar (Either (Cache, GatewayException) Cache)) + +cacheLoop :: DiscordHandleCache -> Chan T.Text -> IO () +cacheLoop (eventChan, cache) log = do + ready <- readChan eventChan + case ready of + Right (Ready _ user dmChannels _unavailableGuilds _) -> do + let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels) + putMVar cache (Right (Cache user dmChans M.empty M.empty)) + 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 + loop :: IO () + loop = forever $ do + eventOrExcept <- readChan eventChan + 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 -> Event -> Cache +adjustCache minfo event = case event of + --ChannelCreate Channel + --ChannelUpdate Channel + --ChannelDelete Channel + GuildCreate guild info -> + let newChans = map (setChanGuildID (guildId guild)) $ guildChannels info + g = M.insert (guildId guild) (guild, info { guildChannels = newChans }) (_guilds minfo) + c = M.unionWith (\a _ -> a) + (M.fromList [ (channelId ch, ch) | ch <- newChans ]) + (_channels minfo) + in minfo { _guilds = g, _channels = c } + --GuildUpdate guild -> do + -- let g = M.insert (guildId guild) guild (_guilds minfo) + -- m2 = minfo { _guilds = g } + -- putMVar cache m2 + --GuildDelete guild -> do + -- let g = M.delete (guildId guild) (_guilds minfo) + -- c = M.filterWithKey (\(keyGuildId,_) _ -> keyGuildId /= guildId guild) (_channels minfo) + -- m2 = minfo { _guilds = g, _channels = c } + -- putMVar cache m2 + _ -> minfo + +setChanGuildID :: GuildId -> Channel -> Channel +setChanGuildID s c = if channelIsInGuild c + then c { channelGuild = s } + else c diff --git a/src/Discord/Internal/Gateway/EventLoop.hs b/src/Discord/Internal/Gateway/EventLoop.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Gateway/EventLoop.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | 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) +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, handle, SomeException) +import Data.Monoid ((<>)) +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 Wuss (runSecureClient) +import Network.WebSockets (ConnectionException(..), Connection, + receiveData, sendTextData) + +import Discord.Internal.Types + +data GatewayException = GatewayExceptionCouldNotConnect T.Text + | GatewayExceptionEventParseError T.Text T.Text + | GatewayExceptionUnexpected GatewayReceivable T.Text + | GatewayExceptionConnection ConnectionException T.Text + deriving (Show) + +data ConnLoopState = ConnStart + | ConnClosed + | ConnReconnect Auth T.Text Integer + deriving Show + +-- | Securely run a connection IO action. Send a close on exception +connect :: (Connection -> IO a) -> IO a +connect = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" + +type DiscordHandleGateway = (Chan (Either GatewayException Event), Chan GatewaySendable) + +connectionLoop :: Auth -> DiscordHandleGateway -> Chan T.Text -> IO () +connectionLoop auth (events, userSend) log = loop ConnStart 0 + where + loop :: ConnLoopState -> Int -> IO () + loop s retries = + case s of + (ConnClosed) -> pure () + (ConnStart) -> do + -- only try-catch an IO Error + next <- try $ connect $ \conn -> do + msg <- getPayload conn log + case msg of + Right (Hello interval) -> do + sendTextData conn (encode (Identify auth False 50 (0, 1))) + msg2 <- getPayload conn log + case msg2 of + Right (Dispatch r@(Ready _ _ _ _ seshID) _) -> do + writeChan events (Right r) + startEventStream (ConnData conn seshID auth events) interval 0 userSend log + Right m -> do writeChan events (Left (GatewayExceptionUnexpected m + "Response to Identify must be Ready")) + pure ConnClosed + Left ce -> do writeChan events (Left (GatewayExceptionConnection ce + "Response to Identify")) + pure ConnClosed + Right m -> do writeChan log ("gateway - first message must be hello: " <> T.pack (show msg)) + writeChan events (Left (GatewayExceptionUnexpected m + "Response to connecting must be hello")) + pure ConnClosed + Left ce -> do writeChan events (Left (GatewayExceptionConnection ce + "Response to connecting")) + pure ConnClosed + case next :: Either SomeException ConnLoopState of + Left _ -> do writeChan events (Left (GatewayExceptionCouldNotConnect + "SomeException in gateway Connection")) + loop ConnClosed 0 + Right n -> loop n 0 + + (ConnReconnect (Auth tok) seshID seqID) -> do + next <- try $ connect $ \conn -> do + sendTextData conn (encode (Resume tok seshID seqID)) + eitherPayload <- getPayload conn log + case eitherPayload of + Right (Hello interval) -> + startEventStream (ConnData conn seshID auth events) interval seqID userSend log + Right (InvalidSession retry) -> do + t <- getRandomR (1,5) + threadDelay (t * 10^6) + pure $ if retry + then ConnReconnect (Auth tok) seshID seqID + else ConnStart + Right payload -> do + writeChan events (Left (GatewayExceptionUnexpected payload + "Response to Resume must be Hello/Invalid Session")) + pure ConnClosed + Left e -> do + writeChan events (Left (GatewayExceptionConnection e + "Could not ConnReconnect")) + pure ConnClosed + case next :: Either SomeException ConnLoopState of + Left _ -> do t <- getRandomR (3,20) + threadDelay (t * 10^6) + writeChan log ("gateway - trying to reconnect after " <> T.pack (show retries) + <> " failures") + loop (ConnReconnect (Auth tok) seshID seqID) (retries + 1) + Right n -> loop n 1 + + +getPayloadTimeout :: Connection -> Int -> Chan T.Text -> IO (Either ConnectionException GatewayReceivable) +getPayloadTimeout conn interval log = do + res <- race (threadDelay ((interval * 1000 * 3) `div` 2)) + (getPayload conn log) + case res of + Left () -> pure (Right Reconnect) + Right other -> pure other + +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 parse Error - " <> T.pack err + <> " while decoding " <> TE.decodeUtf8 (BL.toStrict msg')) + pure (ParseError (T.pack err)) + +heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> IO () +heartbeat send interval seqKey = do + threadDelay (1 * 10^6) + forever $ do + num <- readIORef seqKey + writeChan send (Heartbeat num) + threadDelay (interval * 1000) + +setSequence :: IORef Integer -> Integer -> IO () +setSequence key i = writeIORef key i + +-- | What we need to start an event stream +data ConnectionData = ConnData { connection :: Connection + , connSessionID :: T.Text + , connAuth :: Auth + , connChan :: Chan (Either GatewayException Event) + } + +startEventStream :: ConnectionData -> Int -> Integer -> Chan GatewaySendable -> Chan T.Text -> IO ConnLoopState +startEventStream conndata interval seqN userSend log = do + seqKey <- newIORef seqN + let err :: SomeException -> IO ConnLoopState + err e = do writeChan log ("gateway - eventStream error: " <> T.pack (show e)) + ConnReconnect (connAuth conndata) (connSessionID conndata) <$> readIORef seqKey + handle err $ do + gateSends <- newChan + sendsId <- forkIO $ sendableLoop (connection conndata) (Sendables userSend gateSends) + heart <- forkIO $ heartbeat gateSends interval seqKey + + finally (eventStream conndata seqKey interval gateSends log) + (killThread heart >> killThread sendsId) + + +eventStream :: ConnectionData -> IORef Integer -> Int -> Chan GatewaySendable + -> Chan T.Text -> IO ConnLoopState +eventStream (ConnData conn seshID auth eventChan) seqKey interval send log = loop + where + loop :: IO ConnLoopState + loop = do + eitherPayload <- getPayloadTimeout conn interval log + case eitherPayload :: Either ConnectionException GatewayReceivable of + Left (CloseRequest code str) -> case code of + -- see Discord and MDN documentation on gateway close event codes + 1000 -> ConnReconnect auth seshID <$> readIORef seqKey + 1001 -> ConnReconnect auth seshID <$> readIORef seqKey + 4000 -> ConnReconnect auth seshID <$> readIORef seqKey + 4006 -> pure ConnStart + 4007 -> ConnReconnect auth seshID <$> readIORef seqKey + 4014 -> ConnReconnect auth seshID <$> readIORef seqKey + _ -> do writeChan eventChan (Left (GatewayExceptionConnection (CloseRequest code str) + "Normal event loop close request")) + pure ConnClosed + Left _ -> ConnReconnect auth seshID <$> readIORef seqKey + Right (Dispatch event sq) -> do setSequence seqKey sq + writeChan eventChan (Right event) + loop + Right (HeartbeatRequest sq) -> do setSequence seqKey sq + writeChan send (Heartbeat sq) + loop + Right (Reconnect) -> ConnReconnect auth seshID <$> readIORef seqKey + Right (InvalidSession retry) -> if retry + then ConnReconnect auth seshID <$> readIORef seqKey + else pure ConnStart + Right (HeartbeatAck) -> loop + Right (Hello e) -> do writeChan eventChan (Left (GatewayExceptionUnexpected (Hello e) + "Normal event loop")) + pure ConnClosed + Right (ParseError e) -> do writeChan eventChan (Left (GatewayExceptionEventParseError e + "Normal event loop")) + pure ConnClosed + +data Sendables = Sendables { -- | Things the user wants to send. Doesn't reset on reconnect + userSends :: Chan GatewaySendable -- ^ Things the user wants to send + -- | Things the library needs to send. Resets to empty on reconnect + , gatewaySends :: Chan GatewaySendable + } + +sendableLoop :: Connection -> Sendables -> IO () +sendableLoop conn sends = forever $ do + -- send a ~120 events a min by delaying + threadDelay (round (10^6 * (62 / 120))) + let e :: Either GatewaySendable GatewaySendable -> GatewaySendable + e = either id id + payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends)) + sendTextData conn (encode payload) diff --git a/src/Discord/Internal/Rest.hs b/src/Discord/Internal/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest.hs @@ -0,0 +1,48 @@ +{-# 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 + , DiscordHandleRestChan + , 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 + +type DiscordHandleRestChan = Chan (String, JsonRequest, MVar (Either RestCallInternalException BL.ByteString)) + +-- | Starts the http request thread. Please only call this once +startRestThread :: Auth -> Chan T.Text -> IO (DiscordHandleRestChan, ThreadId) +startRestThread auth log = do + c <- newChan + tid <- forkIO $ restLoop auth c log + pure (c, tid) + +-- | Execute a request blocking until a response is received +writeRestCall :: (Request (r a), FromJSON a) => DiscordHandleRestChan -> r a -> IO (Either RestCallInternalException a) +writeRestCall c req = do + m <- newEmptyMVar + writeChan 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/src/Discord/Internal/Rest/Channel.hs b/src/Discord/Internal/Rest/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Channel.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Channel + ( ChannelRequest(..) + , ReactionTiming(..) + , MessageTiming(..) + , ChannelInviteOpts(..) + , ModifyChannelOpts(..) + , ChannelPermissionsOpts(..) + , GroupDMAddRecipientOpts(..) + , ChannelPermissionsOptsType(..) + ) where + + +import Data.Aeson +import Data.Emoji (unicodeByName) +import Data.Monoid (mempty, (<>)) +import qualified Data.Text as T +import qualified Data.ByteString as B +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody) +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (ChannelRequest a) where + majorRoute = channelMajorRoute + jsonRequest = channelJsonRequest + +-- | Data constructor for requests. See +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 an Embed to a channel. + CreateMessageEmbed :: ChannelId -> T.Text -> Embed -> ChannelRequest Message + -- | Sends a message with a file to a channel. + CreateMessageUploadFile :: ChannelId -> T.Text -> B.ByteString -> 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 () + -- | List of users that reacted with this emoji + GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest () + -- | Delete all reactions on a message + DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () + -- | Edits a message content. + EditMessage :: (ChannelId, MessageId) -> T.Text -> Maybe Embed + -> 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 -> OverwriteId -> 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 -> OverwriteId -> 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 () + + +-- | Data constructor for GetReaction requests +data ReactionTiming = BeforeReaction MessageId + | AfterReaction MessageId + +reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https +reactionTimingToQuery t = case t of + (BeforeReaction snow) -> "before" R.=: show snow + (AfterReaction snow) -> "after" R.=: show snow + +-- | Data constructor for GetChannelMessages requests. See +data MessageTiming = AroundMessage MessageId + | BeforeMessage MessageId + | AfterMessage MessageId + | LatestMessages + +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 + +data ChannelInviteOpts = ChannelInviteOpts + { channelInviteOptsMaxAgeSeconds :: Maybe Integer + , channelInviteOptsMaxUsages :: Maybe Integer + , channelInviteOptsIsTemporary :: Maybe Bool + , channelInviteOptsDontReuseSimilarInvite :: Maybe Bool + } + +instance ToJSON ChannelInviteOpts where + toJSON ChannelInviteOpts{..} = object [(name, val) | (name, Just val) <- + [("max_age", toJSON <$> channelInviteOptsMaxAgeSeconds), + ("max_uses", toJSON <$> channelInviteOptsMaxUsages), + ("temporary", toJSON <$> channelInviteOptsIsTemporary), + ("unique", toJSON <$> channelInviteOptsDontReuseSimilarInvite) ] ] + +data ModifyChannelOpts = ModifyChannelOpts + { modifyChannelName :: Maybe T.Text + , modifyChannelPosition :: Maybe Integer + , modifyChannelTopic :: Maybe T.Text + , modifyChannelNSFW :: Maybe Bool + , modifyChannelBitrate :: Maybe Integer + , modifyChannelUserRateLimit :: Maybe Integer + , modifyChannelPermissionOverwrites :: Maybe [Overwrite] + , modifyChannelParentId :: Maybe ChannelId + } + +instance ToJSON ModifyChannelOpts where + toJSON ModifyChannelOpts{..} = object [(name, val) | (name, Just val) <- + [("name", toJSON <$> modifyChannelName), + ("position", toJSON <$> modifyChannelPosition), + ("topic", toJSON <$> modifyChannelTopic), + ("nsfw", toJSON <$> modifyChannelNSFW), + ("bitrate", toJSON <$> modifyChannelBitrate), + ("user_limit", toJSON <$> modifyChannelUserRateLimit), + ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites), + ("parent_id", toJSON <$> modifyChannelParentId) ] ] + +data ChannelPermissionsOpts = ChannelPermissionsOpts + { channelPermissionsOptsAllow :: Integer + , channelPermissionsOptsDeny :: Integer + , channelPermissionsOptsType :: ChannelPermissionsOptsType} + +data ChannelPermissionsOptsType = ChannelPermissionsOptsUser + | ChannelPermissionsOptsRole + +instance ToJSON ChannelPermissionsOptsType where + toJSON t = case t of ChannelPermissionsOptsUser -> String "member" + ChannelPermissionsOptsRole -> String "role" + +instance ToJSON ChannelPermissionsOpts where + toJSON (ChannelPermissionsOpts a d t) = object [ ("allow", toJSON a ) + , ("deny", toJSON d) + , ("type", toJSON t)] + +-- | https://discordapp.com/developers/docs/resources/channel#group-dm-add-recipient +data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts + { groupDMAddRecipientUserToAdd :: UserId + , groupDMAddRecipientUserToAddNickName :: T.Text + , groupDMAddRecipientGDMJoinAccessToken :: T.Text + } + +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 + (CreateMessageEmbed chan _ _) -> "msg " <> show chan + (CreateMessageUploadFile chan _ _) -> "msg " <> show chan + (CreateReaction (chan, _) _) -> "add_react " <> show chan + (DeleteOwnReaction (chan, _) _) -> "react " <> show chan + (DeleteUserReaction (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 + +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 + +maybeEmbed :: Maybe Embed -> [(T.Text, Value)] +maybeEmbed = maybe [] $ \embed -> ["embed" .= embed] + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +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) (R.ReqBodyJson patch) mempty + + (DeleteChannel chan) -> + Delete (channels // chan) mempty + + (GetChannelMessages chan (n,timing)) -> + let n' = if n < 1 then 1 else (if n > 100 then 100 else 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 + + (CreateMessageEmbed chan msg embed) -> + let content = ["content" .= msg] <> maybeEmbed (Just embed) + body = pure $ R.ReqBodyJson $ object content + in Post (channels // chan /: "messages") body mempty + + (CreateMessageUploadFile chan fileName file) -> + let part = partFileRequestBody "file" (T.unpack fileName) $ RequestBodyBS file + body = R.reqBodyMultipart [part] + 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 + + (GetReactions (chan, msgid) emoji (n, timing)) -> + let e = cleanupEmoji emoji + n' = if n < 1 then 1 else (if n > 100 then 100 else 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 + + (EditMessage (chan, msg) new embed) -> + let content = ["content" .= new] <> maybeEmbed embed + body = R.ReqBodyJson $ object content + 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 perm patch) -> + Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty + + (GetChannelInvites chan) -> + Get (channels // chan /: "invites") mempty + + (CreateChannelInvite chan patch) -> + Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty + + (DeleteChannelPermission chan perm) -> + Delete (channels // chan /: "permissions" // perm) 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 + diff --git a/src/Discord/Internal/Rest/Emoji.hs b/src/Discord/Internal/Rest/Emoji.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Emoji.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Emoji + ( EmojiRequest(..) + , ModifyGuildEmojiOpts(..) + , parseEmojiImage + ) where + +import Data.Aeson +import Data.Monoid (mempty, (<>)) +import Codec.Picture +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 (EmojiRequest a) where + majorRoute = emojiMajorRoute + jsonRequest = emojiJsonRequest + + +-- | Data constructor for requests. See +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 -> EmojiImageParsed -> 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] + } + +instance ToJSON ModifyGuildEmojiOpts where + toJSON (ModifyGuildEmojiOpts name roles) = + object [ "name" .= name, "roles" .= roles ] + + +data EmojiImageParsed = EmojiImageParsed T.Text + +parseEmojiImage :: B.ByteString -> Either T.Text EmojiImageParsed +parseEmojiImage bs = + if B.length bs > 256000 + then Left "Cannot create emoji - File is larger than 256kb" + else case (decodeGifImages bs, decodeImage bs) of + (Left e1, Left e2) -> Left ("Could not parse image or gif: " <> T.pack e1 + <> " and " <> T.pack e2) + (Right ims, _) -> if all is128 ims + then Right (EmojiImageParsed ("data:text/plain;" + <> "base64," + <> TE.decodeUtf8 (B64.encode bs))) + else Left "The frames are not all 128x128" + (_, Right im) -> if is128 im + then Right (EmojiImageParsed ("data:text/plain;" + <> "base64," + <> TE.decodeUtf8 (B64.encode bs))) + else Left "Image is not 128x128" + where + is128 im = let i = convertRGB8 im + in imageWidth i == 128 && imageHeight i == 128 + + +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 + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +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 (EmojiImageParsed im)) -> + Post (guilds // g /: "emojis") + (pure (R.ReqBodyJson (object [ "name" .= name + , "image" .= im + -- todo , "roles" .= ... + ]))) + mempty + (ModifyGuildEmoji g e o) -> Patch (guilds // g /: "emojis" // e) + (R.ReqBodyJson o) + mempty + (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty diff --git a/src/Discord/Internal/Rest/Guild.hs b/src/Discord/Internal/Rest/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Guild.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.Guild + ( GuildRequest(..) + , CreateGuildChannelOpts(..) + , CreateGuildOpts(..) + , ModifyGuildOpts(..) + , AddGuildMemberOpts(..) + , ModifyGuildMemberOpts(..) + , GuildMembersTiming(..) + , CreateGuildBanOpts(..) + , ModifyGuildRoleOpts(..) + , CreateGuildIntegrationOpts(..) + , ModifyGuildIntegrationOpts(..) + ) where + + +import Data.Aeson +import Data.Monoid (mempty, (<>)) +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 (GuildRequest a) where + majorRoute = guildMajorRoute + jsonRequest = guildJsonRequest + +-- | Data constructor for requests. See +data GuildRequest a where + CreateGuild :: CreateGuildOpts -> GuildRequest 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 () + -- | 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 [Ban] + -- | Returns a 'Ban' object for the user banned from this guild. Requires the + -- 'BAN_MEMBERS' permission + GetGuildBan :: GuildId -> UserId -> GuildRequest Ban + -- | 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 Role + -- | 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 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission. + GetGuildEmbed :: GuildId -> GuildRequest GuildEmbed + -- | Modify a 'GuildEmbed' object for the guild. All attributes may be passed in with + -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated + -- 'GuildEmbed' object. + ModifyGuildEmbed :: GuildId -> GuildEmbed -> GuildRequest GuildEmbed + -- | Vanity URL + GetGuildVanityURL :: GuildId -> GuildRequest T.Text + +data CreateGuildOpts = CreateGuildOpts + { createGuildOptsName :: T.Text + , createGuildOptsChannels :: [Channel] + } deriving (Show, Eq, Ord) + +instance ToJSON CreateGuildOpts where + toJSON CreateGuildOpts{..} = object [(name, val) | (name, Just val) <- + [ ("name", toJSON <$> pure createGuildOptsName ) + , ("channels", toJSON <$> pure createGuildOptsChannels ) ]] + +data ModifyGuildIntegrationOpts = ModifyGuildIntegrationOpts + { modifyGuildIntegrationOptsExpireBehavior :: Integer + , modifyGuildIntegrationOptsExpireGraceSeconds :: Integer + , modifyGuildIntegrationOptsEmoticonsEnabled :: Bool + } deriving (Show, Eq, Ord) + +instance ToJSON ModifyGuildIntegrationOpts where + toJSON ModifyGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- + [ ("expire_grace_period", toJSON <$> pure modifyGuildIntegrationOptsExpireGraceSeconds ) + , ("expire_behavior", toJSON <$> pure modifyGuildIntegrationOptsExpireBehavior ) + , ("enable_emoticons", toJSON <$> pure modifyGuildIntegrationOptsEmoticonsEnabled ) ]] + +data CreateGuildIntegrationOpts = CreateGuildIntegrationOpts + { createGuildIntegrationOptsType :: T.Text + } deriving (Show, Eq, Ord) + +instance ToJSON CreateGuildIntegrationOpts where + toJSON CreateGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- + [("type", toJSON <$> pure createGuildIntegrationOptsType ) ]] + +data CreateGuildBanOpts = CreateGuildBanOpts + { createGuildBanOptsDeleteLastNMessages :: Maybe Int + , createGuildBanOptsReason :: Maybe T.Text + } deriving (Show, Eq, Ord) + +instance ToJSON CreateGuildBanOpts where + toJSON CreateGuildBanOpts{..} = object [(name, val) | (name, Just val) <- + [("delete-message-days", + toJSON <$> createGuildBanOptsDeleteLastNMessages ), + ("reason", toJSON <$> createGuildBanOptsReason )]] + +data ModifyGuildRoleOpts = ModifyGuildRoleOpts + { modifyGuildRoleOptsName :: Maybe T.Text + , modifyGuildRoleOptsPermissions :: Maybe Integer + , modifyGuildRoleOptsColor :: Maybe Integer + , modifyGuildRoleOptsSeparateSidebar :: Bool + , modifyGuildRoleOptsMentionable :: Bool + } deriving (Show, Eq, Ord) + +instance ToJSON ModifyGuildRoleOpts where + toJSON ModifyGuildRoleOpts{..} = object [(name, val) | (name, Just val) <- + [("name", toJSON <$> modifyGuildRoleOptsName ), + ("permissions", toJSON <$> modifyGuildRoleOptsPermissions ), + ("color", toJSON <$> modifyGuildRoleOptsColor ), + ("hoist", toJSON <$> Just modifyGuildRoleOptsSeparateSidebar ), + ("mentionable", toJSON <$> Just modifyGuildRoleOptsMentionable )]] + +data AddGuildMemberOpts = AddGuildMemberOpts + { addGuildMemberOptsAccessToken :: T.Text + , addGuildMemberOptsNickname :: Maybe T.Text + , addGuildMemberOptsRoles :: Maybe [RoleId] + , addGuildMemberOptsIsMuted :: Maybe Bool + , addGuildMemberOptsIsDeafened :: Maybe Bool + } deriving (Show, Eq, Ord) + +instance ToJSON AddGuildMemberOpts where + toJSON AddGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- + [("access_token", toJSON <$> Just addGuildMemberOptsAccessToken ), + ("nick", toJSON <$> addGuildMemberOptsNickname ), + ("roles", toJSON <$> addGuildMemberOptsRoles ), + ("mute", toJSON <$> addGuildMemberOptsIsMuted ), + ("deaf", toJSON <$> addGuildMemberOptsIsDeafened )]] + +data ModifyGuildMemberOpts = ModifyGuildMemberOpts + { modifyGuildMemberOptsNickname :: Maybe T.Text + , modifyGuildMemberOptsRoles :: Maybe [RoleId] + , modifyGuildMemberOptsIsMuted :: Maybe Bool + , modifyGuildMemberOptsIsDeafened :: Maybe Bool + , modifyGuildMemberOptsMoveToChannel :: Maybe ChannelId + } deriving (Show, Eq, Ord) + +instance ToJSON ModifyGuildMemberOpts where + toJSON ModifyGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- + [("nick", toJSON <$> modifyGuildMemberOptsNickname ), + ("roles", toJSON <$> modifyGuildMemberOptsRoles ), + ("mute", toJSON <$> modifyGuildMemberOptsIsMuted ), + ("deaf", toJSON <$> modifyGuildMemberOptsIsDeafened ), + ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel)]] +data CreateGuildChannelOpts + = CreateGuildChannelOptsText { + createGuildChannelOptsTopic :: Maybe T.Text + , createGuildChannelOptsUserMessageRateDelay :: Maybe Integer + , createGuildChannelOptsIsNSFW :: Maybe Bool + , createGuildChannelOptsCategoryId :: Maybe ChannelId } + | CreateGuildChannelOptsVoice { + createGuildChannelOptsBitrate :: Maybe Integer + , createGuildChannelOptsMaxUsers :: Maybe Integer + , createGuildChannelOptsCategoryId :: Maybe ChannelId } + | CreateGuildChannelOptsCategory + deriving (Show, Eq, Ord) + +createChannelOptsToJSON :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value +createChannelOptsToJSON name perms opts = object [(key, val) | (key, Just val) <- optsJSON] + where + optsJSON = case opts of + CreateGuildChannelOptsText{..} -> + [("name", Just (String name)) + ,("type", Just (Number 0)) + ,("permission_overwrites", toJSON <$> Just perms) + ,("topic", toJSON <$> createGuildChannelOptsTopic) + ,("rate_limit_per_user", toJSON <$> createGuildChannelOptsUserMessageRateDelay) + ,("nsfw", toJSON <$> createGuildChannelOptsIsNSFW) + ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] + CreateGuildChannelOptsVoice{..} -> + [("name", Just (String name)) + ,("type", Just (Number 2)) + ,("permission_overwrites", toJSON <$> Just perms) + ,("bitrate", toJSON <$> createGuildChannelOptsBitrate) + ,("user_limit", toJSON <$> createGuildChannelOptsMaxUsers) + ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] + CreateGuildChannelOptsCategory -> + [("name", Just (String name)) + ,("type", Just (Number 4)) + ,("permission_overwrites", toJSON <$> Just perms)] + + +-- | https://discordapp.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, Eq, Ord) + +instance ToJSON ModifyGuildOpts where + toJSON ModifyGuildOpts{..} = object [(name, val) | (name, Just val) <- + [("name", toJSON <$> modifyGuildOptsName ), + ("afk_channel_id", toJSON <$> modifyGuildOptsAFKChannelId ), + ("icon", toJSON <$> modifyGuildOptsIcon ), + ("owner_id", toJSON <$> modifyGuildOptsOwnerId )] ] + +data GuildMembersTiming = GuildMembersTiming + { guildMembersTimingLimit :: Maybe Int + , guildMembersTimingAfter :: Maybe UserId + } + +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 + (CreateGuild _) -> "guild " + (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 + (GetGuildEmbed g) -> "guild_embed " <> show g + (ModifyGuildEmbed g _) -> "guild_embed " <> show g + (GetGuildVanityURL g) -> "guild " <> show g + + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +guilds :: R.Url 'R.Https +guilds = baseUrl /: "guilds" + +guildJsonRequest :: GuildRequest r -> JsonRequest +guildJsonRequest c = case c of + (CreateGuild opts) -> + Post (guilds) (pure (R.ReqBodyJson opts)) mempty + + (GetGuild guild) -> + Get (guilds // guild) mempty + + (ModifyGuild guild patch) -> + Patch (guilds // guild) (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") (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) (R.ReqBodyJson patch) mempty + + (ModifyCurrentUserNick guild name) -> + let patch = object ["nick" .= name] + in Patch (guilds // guild /: "members/@me/nick") (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 Post (guilds // guild /: "roles") (pure (R.ReqBodyJson body)) mempty + + (ModifyGuildRole guild role patch) -> + Post (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 = 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 + + (GetGuildEmbed guild) -> + Get (guilds // guild /: "integrations") mempty + + (ModifyGuildEmbed guild patch) -> + Patch (guilds // guild /: "embed") (R.ReqBodyJson patch) mempty + + (GetGuildVanityURL guild) -> + Get (guilds // guild /: "vanity-url") mempty diff --git a/src/Discord/Internal/Rest/HTTP.hs b/src/Discord/Internal/Rest/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/HTTP.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Provide HTTP primitives +module Discord.Internal.Rest.HTTP + ( restLoop + , Request(..) + , JsonRequest(..) + , RestCallInternalException(..) + ) where + +import Prelude hiding (log) +import Data.Semigroup ((<>)) + +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.List (isPrefixOf) +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 Data.Maybe (fromMaybe) +import Text.Read (readMaybe) +import qualified Network.HTTP.Req as R +import qualified Data.Map.Strict as M + +import Discord.Internal.Types +import Discord.Internal.Rest.Prelude + +data RestCallInternalException = RestCallInternalErrorCode Int B.ByteString B.ByteString + | RestCallInternalNoParse String BL.ByteString + | RestCallInternalHttpException R.HttpException + deriving (Show) + +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 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 (if isPrefixOf "add_react " route + then curtime + 0.25 else i) + (removeAllExpire ratelocker curtime) + NoLimit -> loop ratelocker + +-- Note: we hardcode delay for CreateReaction ("add_react") +-- why the headers are wrong: https://github.com/discordapp/discord-api-docs/issues/182 +-- why I chose to hardcode it: https://github.com/aquarial/discord-haskell/issues/16 + +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 :: RestIO R.LbsResponse -> RestIO (RequestResponse, Timeout) +tryRequest action = do + resp <- action + next10 <- liftIO (round . (+10) <$> getPOSIXTime) + let body = R.responseBody resp + code = R.responseStatusCode resp + status = R.responseStatusMessage resp + remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-Ratelimit-Remaining" + global = fromMaybe False $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global" + resetInt = fromMaybe next10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset" + reset = fromIntegral resetInt + 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 + 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) + (Patch url body opts) -> R.req R.PATCH url body R.lbsResponse (authopt <> opts) + (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) + (Post url body opts) -> do b <- body + R.req R.POST url b R.lbsResponse (authopt <> opts) diff --git a/src/Discord/Internal/Rest/Invite.hs b/src/Discord/Internal/Rest/Invite.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Invite.hs @@ -0,0 +1,49 @@ +{-# 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 Data.Monoid (mempty) +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 +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 " + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +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/src/Discord/Internal/Rest/Prelude.hs b/src/Discord/Internal/Rest/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Prelude.hs @@ -0,0 +1,57 @@ +{-# 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 Data.Default (def) +import Control.Exception.Safe (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import qualified Network.HTTP.Req as R + +import Discord.Internal.Types + +-- | 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://discordapp.com/developers/docs/reference#user-agent + -- Second place where the library version is noted + agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.0.0)" + +-- Append to an URL +infixl 5 // +(//) :: Show a => R.Url scheme -> a -> R.Url scheme +(//) url part = url R./: T.pack (show part) + + +-- | Represtents a HTTP request made to an API that supplies a Json response +data JsonRequest where + Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest + Patch :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest + Put :: R.HttpBody a => R.Url 'R.Https -> 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 + majorRoute :: a -> String + 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 $ def { R.httpConfigCheckResponse = \_ _ _ -> Nothing } diff --git a/src/Discord/Internal/Rest/User.hs b/src/Discord/Internal/Rest/User.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/User.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides actions for Channel API interactions +module Discord.Internal.Rest.User + ( UserRequest(..) + , parseCurrentUserAvatar + , CurrentUserAvatar + ) where + + +import Data.Aeson +import Codec.Picture +import Data.Monoid (mempty, (<>)) +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.Lazy as BL +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 +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 -> CurrentUserAvatar -> 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] + +-- | Formatted avatar data https://discordapp.com/developers/docs/resources/user#avatar-data +data CurrentUserAvatar = CurrentUserAvatar T.Text + +parseCurrentUserAvatar :: B.ByteString -> Either T.Text CurrentUserAvatar +parseCurrentUserAvatar bs = + case decodeImage bs of + Left e -> Left (T.pack e) + Right im -> Right $ CurrentUserAvatar $ "data:image/png;base64," + <> TE.decodeUtf8 (B64.encode (BL.toStrict (encodePng (convertRGBA8 im)))) + + +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 " + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +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 (CurrentUserAvatar im)) -> + Patch (users /: "@me") (R.ReqBodyJson (object [ "username" .= name + , "avatar" .= im ])) 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/src/Discord/Internal/Rest/Voice.hs b/src/Discord/Internal/Rest/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Voice.hs @@ -0,0 +1,41 @@ +{-# 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. See +data VoiceRequest a where + ListVoiceRegions :: VoiceRequest [VoiceRegion] + +voiceMajorRoute :: VoiceRequest a -> String +voiceMajorRoute c = case c of + (ListVoiceRegions) -> "whatever " + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +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/src/Discord/Internal/Rest/Webhook.hs b/src/Discord/Internal/Rest/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Rest/Webhook.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# 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 Data.Monoid (mempty, (<>)) +import qualified Data.Text as T +import Network.HTTP.Req ((/:)) +import qualified Network.HTTP.Req as R +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Client (RequestBody (RequestBodyLBS)) +import Network.HTTP.Client.MultipartFormData (partFileRequestBody) + +import Discord.Internal.Rest.Prelude +import Discord.Internal.Types + +instance Request (WebhookRequest a) where + majorRoute = webhookMajorRoute + jsonRequest = webhookJsonRequest + +-- | Data constructor for requests. See +data WebhookRequest a where + CreateWebhook :: ChannelId -> CreateWebhookOpts -> WebhookRequest Webhook + GetChannelWebhooks :: ChannelId -> WebhookRequest [Webhook] + GetGuildWebhooks :: GuildId -> WebhookRequest [Webhook] + GetWebhook :: WebhookId -> WebhookRequest Webhook + GetWebhookWithToken :: WebhookId -> T.Text -> WebhookRequest Webhook + ModifyWebhook :: WebhookId -> ModifyWebhookOpts + -> WebhookRequest Webhook + ModifyWebhookWithToken :: WebhookId -> T.Text -> ModifyWebhookOpts + -> WebhookRequest Webhook + DeleteWebhook :: WebhookId -> WebhookRequest () + DeleteWebhookWithToken :: WebhookId -> T.Text -> WebhookRequest () + ExecuteWebhookWithToken :: WebhookId -> T.Text -> ExecuteWebhookWithTokenOpts + -> WebhookRequest () + +data ModifyWebhookOpts = ModifyWebhookOpts + { modifyWebhookOptsName :: Maybe T.Text + , modifyWebhookOptsAvatar :: Maybe T.Text + , modifyWebhookOptsChannelId :: Maybe ChannelId + } + +instance ToJSON ModifyWebhookOpts where + toJSON ModifyWebhookOpts{..} = object [(name, val) | (name, Just val) <- + [("channel_id", toJSON <$> modifyWebhookOptsChannelId), + ("name", toJSON <$> modifyWebhookOptsName), + ("avatar", toJSON <$> modifyWebhookOptsAvatar) ] ] + +data CreateWebhookOpts = CreateWebhookOpts + { createWebhookOptsName :: T.Text + , createWebhookOptsAvatar :: Maybe T.Text + } + +instance ToJSON CreateWebhookOpts where + toJSON CreateWebhookOpts{..} = object [(name, val) | (name, Just val) <- + [("name", toJSON <$> Just createWebhookOptsName), + ("avatar", toJSON <$> createWebhookOptsAvatar) ] ] + +data ExecuteWebhookWithTokenOpts = ExecuteWebhookWithTokenOpts + { executeWebhookWithTokenOptsUsername :: Maybe T.Text + , executeWebhookWithTokenOptsContent :: WebhookContent + } + deriving (Show, Eq, Ord) + +data WebhookContent = WebhookContentText T.Text + | WebhookContentFile T.Text BL.ByteString + | WebhookContentEmbeds [Embed] + deriving (Show, Eq, Ord) + +webhookContentJson :: WebhookContent -> [(T.Text, Value)] +webhookContentJson c = case c of + WebhookContentText t -> [("content", toJSON t)] + WebhookContentFile _ _ -> [] + WebhookContentEmbeds e -> [("embeds", toJSON e)] + +instance ToJSON ExecuteWebhookWithTokenOpts where + toJSON ExecuteWebhookWithTokenOpts{..} = object $ [(name, val) | (name, Just val) <- + [("username", toJSON <$> executeWebhookWithTokenOptsUsername)] ] + <> webhookContentJson executeWebhookWithTokenOptsContent + +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) -> "aaaaaahook " <> show w + (GetWebhookWithToken w _) -> "getwebhook " <> show w + (ModifyWebhook w _) -> "modifyhook " <> show w + (ModifyWebhookWithToken w _ _) -> "modifyhook " <> show w + (DeleteWebhook w) -> "deletehook " <> show w + (DeleteWebhookWithToken w _) -> "deletehook " <> show w + (ExecuteWebhookWithToken w _ _) -> "executehk " <> show w + +-- | The base url (Req) for API requests +baseUrl :: R.Url 'R.Https +baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion + where apiVersion = "v6" + +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) -> + Get (baseUrl /: "webhooks" // w) mempty + + (GetWebhookWithToken w t) -> + Get (baseUrl /: "webhooks" // w /: t) mempty + + (ModifyWebhook w patch) -> + Patch (baseUrl /: "webhooks" // w) (R.ReqBodyJson patch) mempty + + (ModifyWebhookWithToken w t p) -> + Patch (baseUrl /: "webhooks" // w /: t) (R.ReqBodyJson p) mempty + + (DeleteWebhook w) -> + Delete (baseUrl /: "webhooks" // w) mempty + + (DeleteWebhookWithToken w t) -> + Delete (baseUrl /: "webhooks" // w /: t) mempty + + (ExecuteWebhookWithToken w tok o) -> + case executeWebhookWithTokenOptsContent o of + WebhookContentFile name text -> + let part = partFileRequestBody "file" (T.unpack name) (RequestBodyLBS text) + body = R.reqBodyMultipart [part] + in Post (baseUrl /: "webhooks" // w /: tok) body mempty + _ -> + let body = pure (R.ReqBodyJson o) + in Post (baseUrl /: "webhooks" // w /: tok) body mempty diff --git a/src/Discord/Internal/Types.hs b/src/Discord/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types.hs @@ -0,0 +1,18 @@ +-- | Provides types and encoding/decoding code. Types should be identical to those provided +-- in the Discord API documentation. +module Discord.Internal.Types + ( module Discord.Internal.Types.Prelude + , module Discord.Internal.Types.Channel + , module Discord.Internal.Types.Events + , module Discord.Internal.Types.Gateway + , module Discord.Internal.Types.Guild + , module Data.Aeson + ) where + +import Discord.Internal.Types.Channel +import Discord.Internal.Types.Events +import Discord.Internal.Types.Gateway +import Discord.Internal.Types.Guild +import Discord.Internal.Types.Prelude + +import Data.Aeson (Object) diff --git a/src/Discord/Internal/Types/Channel.hs b/src/Discord/Internal/Types/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Channel.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Data structures pertaining to Discord Channels +module Discord.Internal.Types.Channel where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Default (Default, def) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time.Clock +import qualified Data.HashMap.Strict as HM +import qualified Data.Vector as V +import qualified Data.Text as T + +import Discord.Internal.Types.Prelude + +-- | Represents information about a user. +data User = User + { userId :: UserId -- ^ The user's id. + , userName :: T.Text -- ^ The user's username (not unique) + , userDiscrim :: T.Text -- ^ The user's 4-digit discord-tag. + , userAvatar :: Maybe T.Text -- ^ The user's avatar hash. + , userIsBot :: Bool -- ^ User is an OAuth2 application. + , userIsWebhook:: Bool -- ^ User is a webhook + , userMfa :: Maybe Bool -- ^ User has two factor authentication enabled on the account. + , userVerified :: Maybe Bool -- ^ Whether the email has been verified. + , userEmail :: Maybe T.Text -- ^ The user's email. + } deriving (Show, Eq, Ord) + +instance FromJSON User where + parseJSON = withObject "User" $ \o -> + User <$> o .: "id" + <*> o .: "username" + <*> o .: "discriminator" + <*> o .:? "avatar" + <*> o .:? "bot" .!= False + <*> pure False -- webhook + <*> o .:? "mfa_enabled" + <*> o .:? "verified" + <*> o .:? "email" + +instance ToJSON User where + toJSON User{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure userId) + , ("username", toJSON <$> pure userName) + , ("discriminator", toJSON <$> pure userDiscrim) + , ("avatar", toJSON <$> userAvatar) + , ("bot", toJSON <$> pure userIsBot) + , ("webhook", toJSON <$> pure userIsWebhook) + , ("mfa_enabled", toJSON <$> userMfa) + , ("verified", toJSON <$> userVerified) + , ("email", toJSON <$> userEmail) + ] ] + +data Webhook = Webhook + { webhookId :: WebhookId + , webhookToken :: Text + , webhookChannelId :: ChannelId + } deriving (Show, Eq, Ord) + +instance FromJSON Webhook where + parseJSON = withObject "Webhook" $ \o -> + Webhook <$> o .: "id" + <*> o .: "token" + <*> o .: "channel_id" + +data ConnectionObject = ConnectionObject + { connectionObjectId :: Text + , connectionObjectName :: Text + , connectionObjectType :: Text + , connectionObjectRevoked :: Bool + , connectionObjectIntegrations :: [IntegrationId] + , connectionObjectVerified :: Bool + , connectionObjectFriendSyncOn :: Bool + , connectionObjectShownInPresenceUpdates :: Bool + , connectionObjectVisibleToOthers :: Bool + } deriving (Show, Eq, Ord) + +instance FromJSON ConnectionObject where + parseJSON = withObject "ConnectionObject" $ \o -> do + integrations <- o .: "integrations" + ConnectionObject <$> o .: "id" + <*> o .: "name" + <*> o .: "type" + <*> o .: "revoked" + <*> sequence (map (.: "id") integrations) + <*> o .: "verified" + <*> o .: "friend_sync" + <*> o .: "show_activity" + <*> ( (==) (1::Int) <$> o .: "visibility") + + +-- | 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 guild (2 - 1000 characters). + , channelPosition :: Integer -- ^ The storing position of the channel. + , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's + , channelTopic :: T.Text -- ^ The topic of the channel. (0 - 1024 chars). + , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the + -- channel + } + -- | A voice channel in a guild. + | ChannelVoice + { channelId :: ChannelId + , channelGuild :: GuildId + , channelName :: T.Text + , channelPosition :: Integer + , channelPermissions :: [Overwrite] + , channelBitRate :: Integer -- ^ The bitrate (in bits) of the channel. + , channelUserLimit :: Integer -- ^ The user limit of the voice channel. + } + -- | DM Channels represent a one-to-one conversation between two users, outside the scope + -- of guilds + | ChannelDirectMessage + { channelId :: ChannelId + , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). + , channelLastMessage :: Maybe MessageId + } + | ChannelGroupDM + { channelId :: ChannelId + , channelRecipients :: [User] + , channelLastMessage :: Maybe MessageId + } + | ChannelGuildCategory + { channelId :: ChannelId + , channelGuild :: GuildId + } deriving (Show, 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 .:? "topic" .!= "" + <*> o .:? "last_message_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 .: "bitrate" + <*> o .: "user_limit" + 3 -> + ChannelGroupDM <$> o .: "id" + <*> o .: "recipients" + <*> o .:? "last_message_id" + 4 -> + ChannelGuildCategory <$> o .: "id" + <*> o .:? "guild_id" .!= 0 + _ -> fail ("Unknown channel type:" <> show type') + +instance ToJSON Channel where + toJSON ChannelText{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> pure channelName) + , ("position", toJSON <$> pure channelPosition) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("topic", toJSON <$> pure channelTopic) + , ("last_message_id", toJSON <$> channelLastMessage) + ] ] + toJSON ChannelDirectMessage{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("recipients", toJSON <$> pure channelRecipients) + , ("last_message_id", toJSON <$> channelLastMessage) + ] ] + toJSON ChannelVoice{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + , ("name", toJSON <$> pure channelName) + , ("position", toJSON <$> pure channelPosition) + , ("permission_overwrites", toJSON <$> pure channelPermissions) + , ("bitrate", toJSON <$> pure channelBitRate) + , ("user_limit", toJSON <$> pure channelUserLimit) + ] ] + toJSON ChannelGroupDM{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("recipients", toJSON <$> pure channelRecipients) + , ("last_message_id", toJSON <$> channelLastMessage) + ] ] + toJSON ChannelGuildCategory{..} = object [(name,value) | (name, Just value) <- + [ ("id", toJSON <$> pure channelId) + , ("guild_id", toJSON <$> pure channelGuild) + ] ] + +-- | 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 + _ -> False + +-- | Permission overwrites for a channel. +data Overwrite = Overwrite + { overwriteId :: OverwriteId -- ^ 'Role' or 'User' id + , overwriteType :: T.Text -- ^ Either "role" or "member + , overwriteAllow :: Integer -- ^ Allowed permission bit set + , overwriteDeny :: Integer -- ^ Denied permission bit set + } deriving (Show, Eq, Ord) + +instance FromJSON Overwrite where + parseJSON = withObject "Overwrite" $ \o -> + Overwrite <$> o .: "id" + <*> o .: "type" + <*> o .: "allow" + <*> o .: "deny" + +instance ToJSON Overwrite where + toJSON Overwrite{..} = object + [ ("id", toJSON overwriteId) + , ("type", toJSON overwriteType) + , ("allow", toJSON overwriteAllow) + , ("deny", toJSON overwriteDeny) + ] + +-- | Represents information about a message in a Discord channel. +data Message = Message + { messageId :: MessageId -- ^ The id of the message + , messageChannel :: ChannelId -- ^ Id of the channel the message + -- was sent in + , messageAuthor :: User -- ^ The 'User' the message was sent + -- by + , messageText :: 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 + , messageNonce :: Maybe Snowflake -- ^ Used for validating if a message + -- was sent + , messagePinned :: Bool -- ^ Whether this message is pinned + , messageGuild :: Maybe GuildId -- ^ The guild the message went to + } deriving (Show, Eq, Ord) + +instance FromJSON Message where + parseJSON = withObject "Message" $ \o -> + Message <$> o .: "id" + <*> o .: "channel_id" + <*> (do isW <- o .:? "webhook_id" + a <- o .: "author" + case isW :: Maybe WebhookId of + Nothing -> pure a + Just _ -> pure $ a { userIsWebhook = True }) + <*> 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 .:? "nonce" + <*> o .:? "pinned" .!= False + <*> o .:? "guild_id" .!= Nothing + +-- | Represents an attached to a message file. +data Attachment = Attachment + { attachmentId :: Snowflake -- ^ 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, 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" + +-- | An embed attached to a message. +data Embed = Embed + { embedTitle :: Maybe T.Text -- ^ Title of the embed + , embedType :: Maybe T.Text -- ^ Type of embed (Always "rich" for webhooks) + , embedDescription :: Maybe T.Text -- ^ Description of embed + , embedUrl :: Maybe T.Text -- ^ URL of embed + , embedTimestamp :: Maybe UTCTime -- ^ The time of the embed content + , embedColor :: Maybe Integer -- ^ The embed color + , embedFields :: [SubEmbed] -- ^ Fields of the embed + } deriving (Show, Eq, Ord) + +instance Default Embed where + def = Embed + { embedTitle = Nothing + , embedType = Nothing + , embedDescription = Nothing + , embedUrl = Nothing + , embedTimestamp = Nothing + , embedColor = Nothing + , embedFields = [] + } + +instance FromJSON Embed where + parseJSON = withObject "Embed" $ \o -> + Embed <$> o .:? "title" + <*> o .:? "type" + <*> o .:? "description" + <*> o .:? "url" + <*> o .:? "timestamp" + <*> o .:? "color" + <*> sequence (HM.foldrWithKey to_embed [] o) + where + to_embed k (Object v) a = case k of + "footer" -> (Footer <$> v .: "text" + <*> v .:? "icon_url" .!= "" + <*> v .:? "proxy_icon_url" .!= "") : a + "image" -> (Image <$> v .: "url" + <*> v .: "proxy_url" + <*> v .: "height" + <*> v .: "width") : a + "thumbnail" -> (Thumbnail <$> v .: "url" + <*> v .: "proxy_url" + <*> v .: "height" + <*> v .: "width") : a + "video" -> (Video <$> v .: "url" + <*> v .: "height" + <*> v .: "width") : a + "provider" -> (Provider <$> v .: "name" + <*> v .:? "url" .!= "") : a + "author" -> (Author <$> v .: "name" + <*> v .:? "url" .!= "" + <*> v .:? "icon_url" .!= "" + <*> v .:? "proxy_icon_url" .!= "") : a + _ -> a + to_embed k (Array v) a = case k of + "fields" -> [Field <$> i .: "name" + <*> i .: "value" + <*> i .: "inline" + | Object i <- V.toList v] ++ a + _ -> a + to_embed _ _ a = a + +instance ToJSON Embed where + toJSON (Embed {..}) = object + [ "title" .= embedTitle + , "type" .= embedType + , "description" .= embedDescription + , "url" .= embedUrl + , "timestamp" .= embedTimestamp + , "color" .= embedColor + ] |> makeSubEmbeds embedFields + where + (|>) :: Value -> HM.HashMap Text Value -> Value + (|>) (Object o) hm = Object $ HM.union o hm + (|>) _ _ = error "Type mismatch" + + makeSubEmbeds :: [SubEmbed] -> HM.HashMap Text Value + makeSubEmbeds = foldr embed HM.empty + + embed :: SubEmbed -> HM.HashMap Text Value -> HM.HashMap Text Value + embed (Thumbnail url _ height width) = + HM.alter (\_ -> Just $ object + [ "url" .= url + , "height" .= height + , "width" .= width + ]) "thumbnail" + embed (Image url _ height width) = + HM.alter (\_ -> Just $ object + [ "url" .= url + , "height" .= height + , "width" .= width + ]) "image" + embed (Author name url icon _) = + HM.alter (\_ -> Just $ object + [ "name" .= name + , "url" .= url + , "icon_url" .= icon + ]) "author" + embed (Footer text icon _) = + HM.alter (\_ -> Just $ object + [ "text" .= text + , "icon_url" .= icon + ]) "footer" + embed (Field name value inline) = + HM.alter (\val -> case val of + Just (Array a) -> Just . Array $ V.cons (object + [ "name" .= name + , "value" .= value + , "inline" .= inline + ]) a + _ -> Just $ toJSON [ + object + [ "name" .= name + , "value" .= value + , "inline" .= inline + ] + ] + ) "fields" + embed _ = id + +-- | Represents a part of an embed. +data SubEmbed + = Thumbnail + T.Text + T.Text + Integer + Integer + | Video + T.Text + Integer + Integer + | Image + T.Text + T.Text + Integer + Integer + | Provider + T.Text + T.Text + | Author + T.Text + T.Text + T.Text + T.Text + | Footer + T.Text + T.Text + T.Text + | Field + T.Text + T.Text + Bool + deriving (Show, Eq, Ord) diff --git a/src/Discord/Internal/Types/Events.hs b/src/Discord/Internal/Types/Events.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Events.hs @@ -0,0 +1,155 @@ +{-# 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 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 + + +-- | Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway. +data Event = + Ready Int User [Channel] [GuildUnavailable] T.Text + | Resumed [T.Text] + | ChannelCreate Channel + | ChannelUpdate Channel + | ChannelDelete Channel + | ChannelPinsUpdate ChannelId (Maybe UTCTime) + | GuildCreate Guild GuildInfo + | GuildUpdate Guild + | GuildDelete GuildUnavailable + | GuildBanAdd GuildId User + | GuildBanRemove GuildId User + | GuildEmojiUpdate GuildId [Emoji] + | GuildIntegrationsUpdate GuildId + | GuildMemberAdd GuildId GuildMember + | GuildMemberRemove GuildId User + | GuildMemberUpdate GuildId [RoleId] User (Maybe T.Text) + | GuildMemberChunk GuildId [GuildMember] + | GuildRoleCreate GuildId Role + | GuildRoleUpdate GuildId Role + | GuildRoleDelete GuildId RoleId + | MessageCreate Message + | MessageUpdate ChannelId MessageId + | MessageDelete ChannelId MessageId + | MessageDeleteBulk ChannelId [MessageId] + | MessageReactionAdd ReactionInfo + | MessageReactionRemove ReactionInfo + | MessageReactionRemoveAll ChannelId MessageId + | PresenceUpdate PresenceInfo + | TypingStart TypingInfo + | UserUpdate User + -- | VoiceStateUpdate + -- | VoiceServerUpdate + | UnknownEvent T.Text Object + deriving (Show, Eq) + +data ReactionInfo = ReactionInfo + { reactionUserId :: UserId + , reactionChannelId :: ChannelId + , reactionMessageId :: MessageId + , reactionEmoji :: Emoji + } deriving (Show, Eq, Ord) + +instance FromJSON ReactionInfo where + parseJSON = withObject "ReactionInfo" $ \o -> + ReactionInfo <$> o .: "user_id" + <*> o .: "channel_id" + <*> o .: "message_id" + <*> o .: "emoji" + +data PresenceInfo = PresenceInfo + { presenceUserId :: UserId + , presenceRoles :: [RoleId] + -- , presenceGame :: Maybe Activity + , presenceGuildId :: GuildId + , presenceStatus :: T.Text + } deriving (Show, Eq, Ord) + +instance FromJSON PresenceInfo where + parseJSON = withObject "PresenceInfo" $ \o -> + PresenceInfo <$> (o .: "user" >>= (.: "id")) + <*> o .: "roles" + -- <*> o .: "game" + <*> o .: "guild_id" + <*> o .: "status" + +data TypingInfo = TypingInfo + { typingUserId :: UserId + , typingChannelId :: ChannelId + , typingTimestamp :: UTCTime + } deriving (Show, 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 + +eventParse :: T.Text -> Object -> Parser Event +eventParse t o = case t of + "READY" -> Ready <$> o .: "v" + <*> o .: "user" + <*> o .: "private_channels" + <*> o .: "guilds" + <*> o .: "session_id" + "RESUMED" -> Resumed <$> o .: "_trace" + "CHANNEL_CREATE" -> ChannelCreate <$> reparse o + "CHANNEL_UPDATE" -> ChannelUpdate <$> reparse o + "CHANNEL_DELETE" -> ChannelDelete <$> reparse o + "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" + stamp <- o .:? "last_pin_timestamp" + let utc = stamp >>= parseISO8601 + pure (ChannelPinsUpdate id utc) + "GUILD_CREATE" -> GuildCreate <$> reparse o <*> reparse o + "GUILD_UPDATE" -> GuildUpdate <$> reparse o + "GUILD_DELETE" -> GuildDelete <$> reparse o + "GUILD_BAN_ADD" -> GuildBanAdd <$> o .: "guild_id" <*> o .: "user" + "GUILD_BAN_REMOVE" -> GuildBanRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_EMOJI_UPDATE" -> GuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" + "GUILD_INTEGRATIONS_UPDATE" -> GuildIntegrationsUpdate <$> o .: "guild_id" + "GUILD_MEMBER_ADD" -> GuildMemberAdd <$> o .: "guild_id" <*> reparse o + "GUILD_MEMBER_REMOVE" -> GuildMemberRemove <$> o .: "guild_id" <*> o .: "user" + "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> o .: "guild_id" + <*> o .: "roles" + <*> o .: "user" + <*> o .:? "nick" + "GUILD_MEMBERS_CHUNK" -> GuildMemberChunk <$> o .: "guild_id" <*> o .: "members" + "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" + "GUILD_ROLE_DELETE" -> GuildRoleDelete <$> o .: "guild_id" <*> o .: "role_id" + "MESSAGE_CREATE" -> MessageCreate <$> reparse o + "MESSAGE_UPDATE" -> MessageUpdate <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE" -> MessageDelete <$> o .: "channel_id" <*> o .: "id" + "MESSAGE_DELETE_BULK" -> MessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" + "MESSAGE_REACTION_ADD" -> MessageReactionAdd <$> reparse o + "MESSAGE_REACTION_REMOVE" -> MessageReactionRemove <$> reparse o + "MESSAGE_REACTION_REMOVE_ALL" -> MessageReactionRemoveAll <$> o .: "channel_id" + <*> o .: "message_id" + "PRESENCE_UPDATE" -> PresenceUpdate <$> reparse o + "TYPING_START" -> TypingStart <$> reparse o + "USER_UPDATE" -> UserUpdate <$> reparse o + -- "VOICE_STATE_UPDATE" -> VoiceStateUpdate <$> reparse o + -- "VOICE_SERVER_UPDATE" -> VoiceServerUpdate <$> reparse o + _other_event -> UnknownEvent t <$> reparse o diff --git a/src/Discord/Internal/Types/Gateway.hs b/src/Discord/Internal/Types/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Gateway.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +-- | 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.Monoid ((<>)) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Aeson +import Data.Aeson.Types +import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) + +import Discord.Internal.Types.Prelude +import Discord.Internal.Types.Events + +-- | Represents data sent and received with Discord servers +data GatewayReceivable + = Dispatch Event Integer + | HeartbeatRequest Integer + | Reconnect + | InvalidSession Bool + | Hello Int + | HeartbeatAck + | ParseError T.Text + deriving (Show, Eq) + +data GatewaySendable + = Heartbeat Integer + | Identify Auth Bool Integer (Int, Int) + | Resume T.Text T.Text Integer + | RequestGuildMembers RequestGuildMembersOpts + | UpdateStatus UpdateStatusOpts + | UpdateStatusVoice UpdateStatusVoiceOpts + deriving (Show, Eq, Ord) + +data RequestGuildMembersOpts = RequestGuildMembersOpts + { requestGuildMembersOptsGuildId :: GuildId + , requestGuildMembersOptsNamesStartingWith :: T.Text + , requestGuildMembersOptsLimit :: Integer } + deriving (Show, Eq, Ord) + +data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts + { updateStatusVoiceOptsGuildId :: GuildId + , updateStatusVoiceOptsChannelId :: Maybe ChannelId + , updateStatusVoiceOptsIsMuted :: Bool + , updateStatusVoiceOptsIsDeaf :: Bool + } + deriving (Show, Eq, Ord) + +data UpdateStatusOpts = UpdateStatusOpts + { updateStatusOptsSince :: Maybe UTCTime + , updateStatusOptsGame :: Maybe Activity + , updateStatusOptsNewStatus :: UpdateStatusType + , updateStatusOptsAFK :: Bool + } + deriving (Show, Eq, Ord) + +data Activity = Activity + { activityName :: T.Text + , activityType :: ActivityType + , activityUrl :: Maybe T.Text + } + deriving (Show, Eq, Ord) + +data ActivityType = ActivityTypeGame + | ActivityTypeStreaming + | ActivityTypeListening + | ActivityTypeWatching + deriving (Show, Eq, Ord, Enum) + +data UpdateStatusType = UpdateStatusOnline + | UpdateStatusDoNotDisturb + | UpdateStatusAwayFromKeyboard + | UpdateStatusInvisibleOffline + | UpdateStatusOffline + deriving (Show, Eq, Ord, Enum) + +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 (UnknownEvent ("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 GatewaySendable where + toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ] + toJSON (Identify token compress large shard) = object [ + "op" .= (2 :: Int) + , "d" .= object [ + "token" .= authToken token + , "properties" .= object [ + "$os" .= os + , "$browser" .= ("discord-haskell" :: T.Text) + , "$device" .= ("discord-haskell" :: T.Text) + , "$referrer" .= ("" :: T.Text) + , "$referring_domain" .= ("" :: T.Text) + ] + , "compress" .= compress + , "large_threshold" .= large + , "shard" .= shard + ] + ] + toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [ + "op" .= (3 :: Int) + , "d" .= object [ + "since" .= case since of Nothing -> Nothing + Just s -> Just ((10^6) * (utcTimeToPOSIXSeconds s)) + , "afk" .= afk + , "status" .= statusString status + , "game" .= case game of Nothing -> Nothing + Just a -> Just $ object [ + "name" .= activityName a + , "type" .= (fromEnum $ activityType a :: Int) + , "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 (Resume token session seqId) = object [ + "op" .= (6 :: Int) + , "d" .= object [ + "token" .= token + , "session_id" .= session + , "seq" .= seqId + ] + ] + toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) = + object [ + "op" .= (8 :: Int) + , "d" .= object [ + "guild_id" .= guild + , "query" .= query + , "limit" .= limit + ] + ] diff --git a/src/Discord/Internal/Types/Guild.hs b/src/Discord/Internal/Types/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Guild.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | 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 Discord.Internal.Types.Channel +import Discord.Internal.Types.Prelude + +-- | Representation of a guild member. +data GuildMember = GuildMember + { memberUser :: User + , memberNick :: Maybe T.Text + , memberRoles :: [Snowflake] + , memberJoinedAt :: UTCTime + , memberDeaf :: Bool + , memberMute :: Bool + } deriving (Show, Eq, Ord) + +instance FromJSON GuildMember where + parseJSON = withObject "GuildMember" $ \o -> + GuildMember <$> o .: "user" + <*> o .:? "nick" + <*> o .: "roles" + <*> o .: "joined_at" + <*> o .: "deaf" + <*> o .: "mute" + + +-- https://discordapp.com/developers/docs/resources/guild#guild-object + +-- | Guilds in Discord represent a collection of users and channels into an isolated +-- "Server" +data Guild = Guild + { guildId :: GuildId -- ^ Gulid id + , guildName :: T.Text -- ^ Guild name (2 - 100 chars) + , guildIcon :: Maybe T.Text -- ^ Icon hash + , guildSplash :: Maybe T.Text -- ^ Splash hash + , guildOwnerId :: UserId -- ^ Guild owner id + , guildPermissions :: Maybe Integer + , guildRegion :: T.Text -- ^ Guild voice region + , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel + , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds + , guildEmbedEnabled :: Maybe Bool -- ^ Id of embedded channel + , guildEmbedChannel :: Maybe ChannelId -- ^ Id of embedded channel + , guildVerificationLevel :: Integer -- ^ Level of verification + , guildNotification :: Integer -- ^ Level of default notifications + , guildExplicitFilterLevel :: Integer + , guildRoles :: [Role] -- ^ Array of 'Role' objects + , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects + , guildFeatures :: [T.Text] + , guildMultiFactAuth :: !Integer + , guildApplicationId :: Maybe Snowflake + } deriving (Show, Eq, Ord) + +instance FromJSON Guild where + parseJSON = withObject "Guild" $ \o -> + Guild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "splash" + <*> o .: "owner_id" + <*> o .:? "permissions" + <*> o .: "region" + <*> o .:? "afk_channel_id" + <*> o .: "afk_timeout" + <*> o .:? "embed_enabled" + <*> o .:? "embed_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" + +data GuildUnavailable = GuildUnavailable + { idOnceAvailable :: GuildId + } deriving (Show, Eq, Ord) + +instance FromJSON GuildUnavailable where + parseJSON = withObject "GuildUnavailable" $ \o -> + GuildUnavailable <$> o .: "id" + +data GuildInfo = GuildInfo + { guildJoinedAt :: UTCTime + , guildLarge :: Bool + , guildMemberCount :: Integer + -- , guildVoiceStates :: [VoiceState] -- (without guildid) todo have to add voice state data type + , guildMembers :: [GuildMember] + , guildChannels :: [Channel] -- ^ Channels in the guild (sent in GuildCreate) + -- , guildPresences :: [Presence] + } deriving (Show, Eq, Ord) + +instance FromJSON GuildInfo where + parseJSON = withObject "GuildInfo" $ \o -> + GuildInfo <$> o .: "joined_at" + <*> o .: "large" + <*> o .: "member_count" + -- <*> o .: "voice_states" + <*> o .: "members" + <*> o .: "channels" + +data PartialGuild = PartialGuild + { partialGuildId :: GuildId + , partialGuildName :: T.Text + , partialGuildIcon :: Maybe T.Text + , partialGuildOwner :: Bool + , partialGuildPermissions :: Integer + } deriving (Show, Eq, Ord) + +instance FromJSON PartialGuild where + parseJSON = withObject "PartialGuild" $ \o -> + PartialGuild <$> o .: "id" + <*> o .: "name" + <*> o .:? "icon" + <*> o .:? "owner" .!= False + <*> o .: "permissions" + +-- | Represents an emoticon (emoji) +data Emoji = Emoji + { emojiId :: Maybe EmojiId -- ^ The emoji id + , emojiName :: T.Text -- ^ The emoji name + , emojiRoles :: Maybe [RoleId] -- ^ Roles the emoji is active for + , emojiManaged :: Maybe Bool -- ^ Whether this emoji is managed + } deriving (Show, Eq, Ord) + +instance FromJSON Emoji where + parseJSON = withObject "Emoji" $ \o -> + Emoji <$> o .: "id" + <*> o .: "name" + <*> o .:? "roles" + <*> o .:? "managed" + +-- | 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 :: Integer -- ^ Integer representation of color code + , roleHoist :: Bool -- ^ If the role is pinned in the user listing + , rolePos :: Integer -- ^ Position of this role + , rolePerms :: Integer -- ^ Permission bit set + , roleManaged :: Bool -- ^ Whether this role is managed by an integration + , roleMention :: Bool -- ^ Whether this role is mentionable + } deriving (Show, 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" + +-- | 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 + , voiceRegionDepreciated :: Bool -- ^ Whether this is a deprecated region + , voiceRegionCustom :: Bool -- ^ Whether this is a custom region + } deriving (Show, 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 Ban = Ban + { banReason :: T.Text + , banUser :: User + } deriving (Show, Eq, Ord) + +instance FromJSON Ban where + parseJSON = withObject "Ban" $ \o -> Ban <$> 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, 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, 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, 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, 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 GuildEmbed = GuildEmbed + { embedEnabled :: Bool -- ^ Whether the embed is enabled + , embedChannel :: ChannelId -- ^ The embed channel id + } deriving (Show, Eq, Ord) + +instance FromJSON GuildEmbed where + parseJSON = withObject "GuildEmbed" $ \o -> + GuildEmbed <$> o .: "enabled" <*> o .: "snowflake" + +instance ToJSON GuildEmbed where + toJSON (GuildEmbed enabled snowflake) = object + [ "enabled" .= enabled + , "snowflake" .= snowflake + ] diff --git a/src/Discord/Internal/Types/Prelude.hs b/src/Discord/Internal/Types/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Internal/Types/Prelude.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides base types and utility functions needed for modules in Discord.Internal.Types +module Discord.Internal.Types.Prelude where + +import Data.Bits +import Data.Word + +import Data.Aeson.Types +import Data.Time.Clock +import qualified Data.Text as T +import Data.Time.Clock.POSIX +import Data.Monoid ((<>)) +import Control.Monad (mzero) + +-- | Authorization token for the Discord API +data Auth = Auth T.Text + deriving (Show, 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 Word64 + deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) + +instance Show Snowflake where + show (Snowflake a) = show a + +instance ToJSON Snowflake where + toJSON (Snowflake snowflake) = String . T.pack $ show snowflake + +instance FromJSON Snowflake where + parseJSON (String snowflake) = Snowflake <$> (pure . read $ T.unpack snowflake) + parseJSON _ = mzero + +type ChannelId = Snowflake +type GuildId = Snowflake +type MessageId = Snowflake +type EmojiId = Snowflake +type UserId = Snowflake +type OverwriteId = Snowflake +type RoleId = Snowflake +type IntegrationId = Snowflake +type WebhookId = Snowflake + +-- | 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 + diff --git a/src/Discord/Requests.hs b/src/Discord/Requests.hs new file mode 100644 --- /dev/null +++ b/src/Discord/Requests.hs @@ -0,0 +1,17 @@ +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 + ) 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 diff --git a/src/Discord/Rest.hs b/src/Discord/Rest.hs deleted file mode 100644 --- a/src/Discord/Rest.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_HADDOCK prune, not-home #-} - --- | Provides a higher level interface to the rest functions. --- Preperly writes to the rate-limit loop. Creates separate --- MVars for each call -module Discord.Rest - ( module Discord.Types - , RestChan(..) - , Request(..) - , writeRestCall - , createHandler - , RestCallException(..) - ) 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.Char8 as QL - -import Discord.Types -import Discord.Rest.HTTP - -newtype RestChan = RestChan (Chan (String, JsonRequest, - MVar (Either RestCallException QL.ByteString))) - --- | Starts the http request thread. Please only call this once -createHandler :: Auth -> Chan String -> IO (RestChan, ThreadId) -createHandler auth log = do - c <- newChan - tid <- forkIO $ restLoop auth c log - pure (RestChan c, tid) - --- | Execute a request blocking until a response is received -writeRestCall :: (Request (r a), FromJSON a) => RestChan -> r a -> IO (Either RestCallException a) -writeRestCall (RestChan c) req = do - m <- newEmptyMVar - writeChan c (majorRoute req, jsonRequest req, m) - r <- readMVar m - pure $ case eitherDecode <$> r of - Right (Right o) -> Right o - Right (Left er) -> Left (RestCallNoParse er (case r of Right x -> x - Left _ -> "")) - Left e -> Left e - - diff --git a/src/Discord/Rest/Channel.hs b/src/Discord/Rest/Channel.hs deleted file mode 100644 --- a/src/Discord/Rest/Channel.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides actions for Channel API interactions -module Discord.Rest.Channel - ( ChannelRequest(..) - , ReactionTiming(..) - , MessageTiming(..) - , ChannelInviteOpts(..) - , ModifyChannelOpts(..) - , ChannelPermissionsOpts(..) - , GroupDMAddRecipientOpts(..) - , ChannelPermissionsOptsType(..) - ) where - - -import Data.Aeson -import qualified Data.ByteString.Lazy as BL -import Data.Monoid (mempty, (<>)) -import qualified Data.Text as T -import Network.HTTP.Client (RequestBody (RequestBodyLBS)) -import Network.HTTP.Client.MultipartFormData (partFileRequestBody) -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R - -import Discord.Rest.Prelude -import Discord.Types - -instance Request (ChannelRequest a) where - majorRoute = channelMajorRoute - jsonRequest = channelJsonRequest - --- | Data constructor for requests. See -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 an Embed to a channel. - CreateMessageEmbed :: ChannelId -> T.Text -> Embed -> ChannelRequest Message - -- | Sends a message with a file to a channel. - CreateMessageUploadFile :: ChannelId -> T.Text -> BL.ByteString -> 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 () - -- | List of users that reacted with this emoji - GetReactions :: (ChannelId, MessageId) -> T.Text -> (Int, ReactionTiming) -> ChannelRequest () - -- | Delete all reactions on a message - DeleteAllReactions :: (ChannelId, MessageId) -> ChannelRequest () - -- | Edits a message content. - EditMessage :: (ChannelId, MessageId) -> T.Text -> Maybe Embed - -> 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 -> OverwriteId -> 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 -> OverwriteId -> 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 () - - --- | Data constructor for GetReaction requests -data ReactionTiming = BeforeReaction MessageId - | AfterReaction MessageId - -reactionTimingToQuery :: ReactionTiming -> R.Option 'R.Https -reactionTimingToQuery t = case t of - (BeforeReaction snow) -> "before" R.=: show snow - (AfterReaction snow) -> "after" R.=: show snow - --- | Data constructor for GetChannelMessages requests. See -data MessageTiming = AroundMessage MessageId - | BeforeMessage MessageId - | AfterMessage MessageId - | LatestMessages - -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 - -data ChannelInviteOpts = ChannelInviteOpts - { channelInviteOptsMaxAgeSeconds :: Maybe Integer - , channelInviteOptsMaxUsages :: Maybe Integer - , channelInviteOptsIsTemporary :: Maybe Bool - , channelInviteOptsDontReuseSimilarInvite :: Maybe Bool - } - -instance ToJSON ChannelInviteOpts where - toJSON ChannelInviteOpts{..} = object [(name, val) | (name, Just val) <- - [("max_age", toJSON <$> channelInviteOptsMaxAgeSeconds), - ("max_uses", toJSON <$> channelInviteOptsMaxUsages), - ("temporary", toJSON <$> channelInviteOptsIsTemporary), - ("unique", toJSON <$> channelInviteOptsDontReuseSimilarInvite) ] ] - -data ModifyChannelOpts = ModifyChannelOpts - { modifyChannelName :: Maybe String - , modifyChannelPosition :: Maybe Integer - , modifyChannelTopic :: Maybe String - , modifyChannelNSFW :: Maybe Bool - , modifyChannelBitrate :: Maybe Integer - , modifyChannelUserRateLimit :: Maybe Integer - , modifyChannelPermissionOverwrites :: Maybe [Overwrite] - , modifyChannelParentId :: Maybe ChannelId - } - -instance ToJSON ModifyChannelOpts where - toJSON ModifyChannelOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> modifyChannelName), - ("position", toJSON <$> modifyChannelPosition), - ("topic", toJSON <$> modifyChannelTopic), - ("nsfw", toJSON <$> modifyChannelNSFW), - ("bitrate", toJSON <$> modifyChannelBitrate), - ("user_limit", toJSON <$> modifyChannelUserRateLimit), - ("permission_overwrites", toJSON <$> modifyChannelPermissionOverwrites), - ("parent_id", toJSON <$> modifyChannelParentId) ] ] - -data ChannelPermissionsOpts = ChannelPermissionsOpts - { channelPermissionsOptsAllow :: Integer - , channelPermissionsOptsDeny :: Integer - , channelPermissionsOptsType :: ChannelPermissionsOptsType} - -data ChannelPermissionsOptsType = ChannelPermissionsOptsUser - | ChannelPermissionsOptsRole - -instance ToJSON ChannelPermissionsOptsType where - toJSON t = case t of ChannelPermissionsOptsUser -> String "member" - ChannelPermissionsOptsRole -> String "role" - -instance ToJSON ChannelPermissionsOpts where - toJSON (ChannelPermissionsOpts a d t) = object [ ("allow", toJSON a ) - , ("deny", toJSON d) - , ("type", toJSON t)] - --- | https://discordapp.com/developers/docs/resources/channel#group-dm-add-recipient -data GroupDMAddRecipientOpts = GroupDMAddRecipientOpts - { groupDMAddRecipientUserToAdd :: UserId - , groupDMAddRecipientUserToAddNickName :: T.Text - , groupDMAddRecipientGDMJoinAccessToken :: T.Text - } - -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 - (CreateMessageEmbed chan _ _) -> "msg " <> show chan - (CreateMessageUploadFile chan _ _) -> "msg " <> show chan - (CreateReaction (chan, _) _) -> "add_react " <> show chan - (DeleteOwnReaction (chan, _) _) -> "react " <> show chan - (DeleteUserReaction (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 - -cleanupEmoji :: T.Text -> T.Text -cleanupEmoji emoji = - let noAngles = T.replace "<" "" (T.replace ">" "" emoji) - in case T.stripPrefix ":" noAngles of Just a -> "custom:" <> a - Nothing -> noAngles - -maybeEmbed :: Maybe Embed -> [(T.Text, Value)] -maybeEmbed = maybe [] $ \embed -> ["embed" .= embed] - --- | The base url (Req) for API requests -baseUrl :: R.Url 'R.Https -baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion - where apiVersion = "v6" - -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) (R.ReqBodyJson patch) mempty - - (DeleteChannel chan) -> - Delete (channels // chan) mempty - - (GetChannelMessages chan (n,timing)) -> - let n' = if n < 1 then 1 else (if n > 100 then 100 else 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 - - (CreateMessageEmbed chan msg embed) -> - let content = ["content" .= msg] <> maybeEmbed (Just embed) - body = pure $ R.ReqBodyJson $ object content - in Post (channels // chan /: "messages") body mempty - - (CreateMessageUploadFile chan fileName file) -> - let part = partFileRequestBody "file" (T.unpack fileName) $ RequestBodyLBS file - body = R.reqBodyMultipart [part] - 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 - - (GetReactions (chan, msgid) emoji (n, timing)) -> - let e = cleanupEmoji emoji - n' = if n < 1 then 1 else (if n > 100 then 100 else 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 - - (EditMessage (chan, msg) new embed) -> - let content = ["content" .= new] <> maybeEmbed embed - body = R.ReqBodyJson $ object content - 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 perm patch) -> - Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty - - (GetChannelInvites chan) -> - Get (channels // chan /: "invites") mempty - - (CreateChannelInvite chan patch) -> - Post (channels // chan /: "invites") (pure (R.ReqBodyJson patch)) mempty - - (DeleteChannelPermission chan perm) -> - Delete (channels // chan /: "permissions" // perm) 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 - diff --git a/src/Discord/Rest/Emoji.hs b/src/Discord/Rest/Emoji.hs deleted file mode 100644 --- a/src/Discord/Rest/Emoji.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides actions for Channel API interactions -module Discord.Rest.Emoji - ( EmojiRequest(..) - , ModifyGuildEmojiOpts(..) - , parseEmojiImage - ) where - -import Data.Aeson -import Data.Monoid (mempty, (<>)) -import Codec.Picture -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as Q -import qualified Data.ByteString.Base64 as B64 - -import Discord.Rest.Prelude -import Discord.Types - -instance Request (EmojiRequest a) where - majorRoute = emojiMajorRoute - jsonRequest = emojiJsonRequest - - --- | Data constructor for requests. See -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 -> EmojiImageParsed -> 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] - } - -instance ToJSON ModifyGuildEmojiOpts where - toJSON (ModifyGuildEmojiOpts name roles) = - object [ "name" .= name, "roles" .= roles ] - - -data EmojiImageParsed = EmojiImageParsed String - -parseEmojiImage :: Q.ByteString -> Either String EmojiImageParsed -parseEmojiImage bs = - if Q.length bs > 256000 - then Left "Cannot create emoji - File is larger than 256kb" - else case (decodeGifImages bs, decodeImage bs) of - (Left e1, Left e2) -> Left ("Could not parse image or gif: " <> e1 - <> " and " <> e2) - (Right ims, _) -> if all is128 ims - then Right (EmojiImageParsed ("data:text/plain;" - <> "base64," - <> Q.unpack (B64.encode bs))) - else Left ("The frames are not all 128x128") - (_, Right im) -> if is128 im - then Right (EmojiImageParsed ("data:text/plain;" - <> "base64," - <> Q.unpack (B64.encode bs))) - else Left ("Image is not 128x128") - where - is128 im = let i = convertRGB8 im - in imageWidth i == 128 && imageHeight i == 128 - - -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 - --- | The base url (Req) for API requests -baseUrl :: R.Url 'R.Https -baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion - where apiVersion = "v6" - -guilds :: R.Url 'R.Https -guilds = baseUrl /: "guilds" - -emojiJsonRequest :: EmojiRequest r -> JsonRequest -emojiJsonRequest c = case c of - (ListGuildEmojis g) -> Get (guilds // g) mempty - (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty - (CreateGuildEmoji g name (EmojiImageParsed im)) -> - Post (guilds // g /: "emojis") - (pure (R.ReqBodyJson (object [ "name" .= name - , "image" .= im - -- todo , "roles" .= ... - ]))) - mempty - (ModifyGuildEmoji g e o) -> Patch (guilds // g /: "emojis" // e) - (R.ReqBodyJson o) - mempty - (DeleteGuildEmoji g e) -> Delete (guilds // g /: "emojis" // e) mempty diff --git a/src/Discord/Rest/Guild.hs b/src/Discord/Rest/Guild.hs deleted file mode 100644 --- a/src/Discord/Rest/Guild.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides actions for Channel API interactions -module Discord.Rest.Guild - ( GuildRequest(..) - , CreateGuildChannelOpts(..) - , ModifyGuildOpts(..) - , AddGuildMemberOpts(..) - , ModifyGuildMemberOpts(..) - , GuildMembersTiming(..) - , CreateGuildBanOpts(..) - , ModifyGuildRoleOpts(..) - , CreateGuildIntegrationOpts(..) - , ModifyGuildIntegrationOpts(..) - ) where - - -import Data.Aeson -import Data.Monoid (mempty, (<>)) -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T - -import Discord.Rest.Prelude -import Discord.Types - -instance Request (GuildRequest a) where - majorRoute = guildMajorRoute - jsonRequest = guildJsonRequest - --- | Data constructor for requests. See -data GuildRequest a where - -- todo CreateGuild :: So many parameters - -- | 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 Guild - -- | 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 () - -- | 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 [Ban] - -- | Returns a 'Ban' object for the user banned from this guild. Requires the - -- 'BAN_MEMBERS' permission - GetGuildBan :: GuildId -> UserId -> GuildRequest Ban - -- | 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 Role - -- | 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 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission. - GetGuildEmbed :: GuildId -> GuildRequest GuildEmbed - -- | Modify a 'GuildEmbed' object for the guild. All attributes may be passed in with - -- JSON and modified. Requires the 'MANAGE_GUILD' permission. Returns the updated - -- 'GuildEmbed' object. - ModifyGuildEmbed :: GuildId -> GuildEmbed -> GuildRequest GuildEmbed - -- | Vanity URL - GetGuildVanityURL :: GuildId -> GuildRequest T.Text - -data ModifyGuildIntegrationOpts = ModifyGuildIntegrationOpts - { modifyGuildIntegrationOptsExpireBehavior :: Integer - , modifyGuildIntegrationOptsExpireGraceSeconds :: Integer - , modifyGuildIntegrationOptsEmoticonsEnabled :: Bool - } deriving (Show, Eq, Ord) - -instance ToJSON ModifyGuildIntegrationOpts where - toJSON ModifyGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- - [ ("expire_grace_period", toJSON <$> pure modifyGuildIntegrationOptsExpireGraceSeconds ) - , ("expire_behavior", toJSON <$> pure modifyGuildIntegrationOptsExpireBehavior ) - , ("enable_emoticons", toJSON <$> pure modifyGuildIntegrationOptsEmoticonsEnabled ) ]] - -data CreateGuildIntegrationOpts = CreateGuildIntegrationOpts - { createGuildIntegrationOptsType :: T.Text - } deriving (Show, Eq, Ord) - -instance ToJSON CreateGuildIntegrationOpts where - toJSON CreateGuildIntegrationOpts{..} = object [(name, val) | (name, Just val) <- - [("type", toJSON <$> pure createGuildIntegrationOptsType ) ]] - -data CreateGuildBanOpts = CreateGuildBanOpts - { createGuildBanOptsDeleteLastNMessages :: Maybe Int - , createGuildBanOptsReason :: Maybe T.Text - } deriving (Show, Eq, Ord) - -instance ToJSON CreateGuildBanOpts where - toJSON CreateGuildBanOpts{..} = object [(name, val) | (name, Just val) <- - [("delete-message-days", - toJSON <$> createGuildBanOptsDeleteLastNMessages ), - ("reason", toJSON <$> createGuildBanOptsReason )]] - -data ModifyGuildRoleOpts = ModifyGuildRoleOpts - { modifyGuildRoleOptsName :: Maybe T.Text - , modifyGuildRoleOptsPermissions :: Maybe Integer - , modifyGuildRoleOptsColor :: Maybe Integer - , modifyGuildRoleOptsSeparateSidebar :: Bool - , modifyGuildRoleOptsMentionable :: Bool - } deriving (Show, Eq, Ord) - -instance ToJSON ModifyGuildRoleOpts where - toJSON ModifyGuildRoleOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> modifyGuildRoleOptsName ), - ("permissions", toJSON <$> modifyGuildRoleOptsPermissions ), - ("color", toJSON <$> modifyGuildRoleOptsColor ), - ("hoist", toJSON <$> Just modifyGuildRoleOptsSeparateSidebar ), - ("mentionable", toJSON <$> Just modifyGuildRoleOptsMentionable )]] - -data AddGuildMemberOpts = AddGuildMemberOpts - { addGuildMemberOptsAccessToken :: T.Text - , addGuildMemberOptsNickname :: Maybe T.Text - , addGuildMemberOptsRoles :: Maybe [RoleId] - , addGuildMemberOptsIsMuted :: Maybe Bool - , addGuildMemberOptsIsDeafened :: Maybe Bool - } deriving (Show, Eq, Ord) - -instance ToJSON AddGuildMemberOpts where - toJSON AddGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- - [("access_token", toJSON <$> Just addGuildMemberOptsAccessToken ), - ("nick", toJSON <$> addGuildMemberOptsNickname ), - ("roles", toJSON <$> addGuildMemberOptsRoles ), - ("mute", toJSON <$> addGuildMemberOptsIsMuted ), - ("deaf", toJSON <$> addGuildMemberOptsIsDeafened )]] - -data ModifyGuildMemberOpts = ModifyGuildMemberOpts - { modifyGuildMemberOptsNickname :: Maybe T.Text - , modifyGuildMemberOptsRoles :: Maybe [RoleId] - , modifyGuildMemberOptsIsMuted :: Maybe Bool - , modifyGuildMemberOptsIsDeafened :: Maybe Bool - , modifyGuildMemberOptsMoveToChannel :: Maybe ChannelId - } deriving (Show, Eq, Ord) - -instance ToJSON ModifyGuildMemberOpts where - toJSON ModifyGuildMemberOpts{..} = object [(name, val) | (name, Just val) <- - [("nick", toJSON <$> modifyGuildMemberOptsNickname ), - ("roles", toJSON <$> modifyGuildMemberOptsRoles ), - ("mute", toJSON <$> modifyGuildMemberOptsIsMuted ), - ("deaf", toJSON <$> modifyGuildMemberOptsIsDeafened ), - ("channel_id", toJSON <$> modifyGuildMemberOptsMoveToChannel)]] -data CreateGuildChannelOpts - = CreateGuildChannelOptsText { - createGuildChannelOptsTopic :: Maybe T.Text - , createGuildChannelOptsUserMessageRateDelay :: Maybe Integer - , createGuildChannelOptsIsNSFW :: Maybe Bool - , createGuildChannelOptsCategoryId :: Maybe ChannelId } - | CreateGuildChannelOptsVoice { - createGuildChannelOptsBitrate :: Maybe Integer - , createGuildChannelOptsMaxUsers :: Maybe Integer - , createGuildChannelOptsCategoryId :: Maybe ChannelId } - | CreateGuildChannelOptsCategory - deriving (Show, Eq, Ord) - -createChannelOptsToJSON :: T.Text -> [Overwrite] -> CreateGuildChannelOpts -> Value -createChannelOptsToJSON name perms opts = object [(key, val) | (key, Just val) <- optsJSON] - where - optsJSON = case opts of - CreateGuildChannelOptsText{..} -> - [("name", Just (String name)) - ,("type", Just (Number 0)) - ,("permission_overwrites", toJSON <$> Just perms) - ,("topic", toJSON <$> createGuildChannelOptsTopic) - ,("rate_limit_per_user", toJSON <$> createGuildChannelOptsUserMessageRateDelay) - ,("nsfw", toJSON <$> createGuildChannelOptsIsNSFW) - ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] - CreateGuildChannelOptsVoice{..} -> - [("name", Just (String name)) - ,("type", Just (Number 2)) - ,("permission_overwrites", toJSON <$> Just perms) - ,("bitrate", toJSON <$> createGuildChannelOptsBitrate) - ,("user_limit", toJSON <$> createGuildChannelOptsMaxUsers) - ,("parent_id", toJSON <$> createGuildChannelOptsCategoryId)] - CreateGuildChannelOptsCategory -> - [("name", Just (String name)) - ,("type", Just (Number 4)) - ,("permission_overwrites", toJSON <$> Just perms)] - - --- | https://discordapp.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, Eq, Ord) - -instance ToJSON ModifyGuildOpts where - toJSON ModifyGuildOpts{..} = object [(name, val) | (name, Just val) <- - [("name", toJSON <$> modifyGuildOptsName ), - ("afk_channel_id", toJSON <$> modifyGuildOptsAFKChannelId ), - ("icon", toJSON <$> modifyGuildOptsIcon ), - ("owner_id", toJSON <$> modifyGuildOptsOwnerId )] ] - -data GuildMembersTiming = GuildMembersTiming - { guildMembersTimingLimit :: Maybe Int - , guildMembersTimingAfter :: Maybe UserId - } - -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 - (GetGuildEmbed g) -> "guild_embed " <> show g - (ModifyGuildEmbed g _) -> "guild_embed " <> show g - (GetGuildVanityURL g) -> "guild " <> show g - - --- | The base url (Req) for API requests -baseUrl :: R.Url 'R.Https -baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion - where apiVersion = "v6" - -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) (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") (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) (R.ReqBodyJson patch) mempty - - (ModifyCurrentUserNick guild name) -> - let patch = object ["nick" .= name] - in Patch (guilds // guild /: "members/@me/nick") (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 Post (guilds // guild /: "roles") (pure (R.ReqBodyJson body)) mempty - - (ModifyGuildRole guild role patch) -> - Post (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 = 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 - - (GetGuildEmbed guild) -> - Get (guilds // guild /: "integrations") mempty - - (ModifyGuildEmbed guild patch) -> - Patch (guilds // guild /: "embed") (R.ReqBodyJson patch) mempty - - (GetGuildVanityURL guild) -> - Get (guilds // guild /: "vanity-url") mempty diff --git a/src/Discord/Rest/HTTP.hs b/src/Discord/Rest/HTTP.hs deleted file mode 100644 --- a/src/Discord/Rest/HTTP.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiWayIf #-} - --- | Provide HTTP primitives -module Discord.Rest.HTTP - ( restLoop - , Request(..) - , JsonRequest(..) - , RestCallException(..) - ) where - -import Prelude hiding (log) -import Data.Semigroup ((<>)) - -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.List (isPrefixOf) -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import qualified Data.ByteString.Char8 as Q -import qualified Data.ByteString.Lazy.Char8 as QL -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) -import qualified Network.HTTP.Req as R -import qualified Data.Map.Strict as M - -import Discord.Types -import Discord.Rest.Prelude - -data RestCallException = RestCallErrorCode Int Q.ByteString Q.ByteString - | RestCallNoParse String QL.ByteString - | RestCallHttpException R.HttpException - deriving (Show) - -restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either RestCallException QL.ByteString)) - -> Chan String -> 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 action log) - case reqIO :: Either R.HttpException (RequestResponse, Timeout) of - Left e -> do - writeChan log ("rest - http exception " <> show e) - putMVar thread (Left (RestCallHttpException e)) - loop ratelocker - Right (resp, retry) -> do - writeChan log ("rest - response " <> show resp) - 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 (RestCallErrorCode e s b)) - ResponseTryAgain -> writeChan urls (route, request, thread) - case retry of - GlobalWait i -> do - writeChan log ("rest - GLOBAL WAIT LIMIT: " - <> show ((i - curtime) * 1000)) - threadDelay $ round ((i - curtime + 0.1) * 1000) - loop ratelocker - PathWait i -> loop $ M.insert route (if isPrefixOf "add_react " route - then curtime + 0.25 else i) - ratelocker - NoLimit -> loop ratelocker - --- Note: we hardcode delay for CreateReaction ("add_react") --- why the headers are wrong: https://github.com/discordapp/discord-api-docs/issues/182 --- why I chose to hardcode it: https://github.com/aquarial/discord-haskell/issues/16 - -data RateLimited = Available | Locked - -compareRate :: (Ord k, Ord v) => M.Map k v -> k -> v -> RateLimited -compareRate ratelocker route curtime = - case M.lookup route ratelocker of - Just unlockTime -> if curtime < unlockTime then Locked else Available - Nothing -> Available - - -data RequestResponse = ResponseTryAgain - | ResponseByteString QL.ByteString - | ResponseErrorCode Int Q.ByteString Q.ByteString - deriving (Show) - -data Timeout = GlobalWait POSIXTime - | PathWait POSIXTime - | NoLimit - -tryRequest :: RestIO R.LbsResponse -> Chan String -> RestIO (RequestResponse, Timeout) -tryRequest action log = do - resp <- action - next10 <- liftIO (round . (+10) <$> getPOSIXTime) - let body = R.responseBody resp - code = R.responseStatusCode resp - status = R.responseStatusMessage resp - remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-Ratelimit-Remaining" - global = fromMaybe False $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global" - resetInt = fromMaybe next10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset" - reset = fromIntegral resetInt - if | code == 429 -> do liftIO $ writeChan log ("rest - 429 RATE LIMITED global:" - <> show global <> " reset:" <> show reset) - 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 (QL.toStrict body) - , if remain > 0 then NoLimit else PathWait reset ) - | otherwise -> pure (ResponseErrorCode code status (QL.toStrict body), NoLimit) - -readMaybeBS :: Read a => Q.ByteString -> Maybe a -readMaybeBS = readMaybe . Q.unpack - -compileRequest :: Auth -> JsonRequest -> RestIO R.LbsResponse -compileRequest auth request = action - where - authopt = authHeader auth - 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) - (Patch url body opts) -> R.req R.PATCH url body R.lbsResponse (authopt <> opts) - (Put url body opts) -> R.req R.PUT url body R.lbsResponse (authopt <> opts) - (Post url body opts) -> do b <- body - R.req R.POST url b R.lbsResponse (authopt <> opts) diff --git a/src/Discord/Rest/Invite.hs b/src/Discord/Rest/Invite.hs deleted file mode 100644 --- a/src/Discord/Rest/Invite.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides actions for Channel API interactions -module Discord.Rest.Invite - ( InviteRequest(..) - ) where - -import Data.Monoid (mempty) -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T - -import Discord.Rest.Prelude -import Discord.Types - -instance Request (InviteRequest a) where - majorRoute = inviteMajorRoute - jsonRequest = inviteJsonRequest - - --- | Data constructor for requests. See -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 " - --- | The base url (Req) for API requests -baseUrl :: R.Url 'R.Https -baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion - where apiVersion = "v6" - -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/src/Discord/Rest/Prelude.hs b/src/Discord/Rest/Prelude.hs deleted file mode 100644 --- a/src/Discord/Rest/Prelude.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} - --- | Utility and base types and functions for the Discord Rest API -module Discord.Rest.Prelude where - -import Prelude hiding (log) -import Data.Default (def) -import Control.Exception (throwIO) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Monoid ((<>)) -import qualified Data.Text as T -import qualified Network.HTTP.Req as R - -import Discord.Types - --- | Discord requires HTTP headers for authentication. -authHeader :: Auth -> R.Option 'R.Https -authHeader auth = - R.header "Authorization" (formatAuth auth) - <> R.header "User-Agent" agent - where - -- | https://discordapp.com/developers/docs/reference#user-agent - -- Second place where the library version is noted - agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 0.8.4)" - --- Append to an URL -infixl 5 // -(//) :: Show a => R.Url scheme -> a -> R.Url scheme -(//) url part = url R./: T.pack (show part) - - --- | Represtents a HTTP request made to an API that supplies a Json response -data JsonRequest where - Delete :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest - Get :: R.Url 'R.Https -> R.Option 'R.Https -> JsonRequest - Patch :: R.HttpBody a => R.Url 'R.Https -> a -> R.Option 'R.Https -> JsonRequest - Put :: R.HttpBody a => R.Url 'R.Https -> 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 - majorRoute :: a -> String - 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 $ def { R.httpConfigCheckResponse = \_ _ _ -> Nothing } diff --git a/src/Discord/Rest/User.hs b/src/Discord/Rest/User.hs deleted file mode 100644 --- a/src/Discord/Rest/User.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides actions for Channel API interactions -module Discord.Rest.User - ( UserRequest(..) - , parseCurrentUserAvatar - , CurrentUserAvatar - ) where - - -import Data.Aeson -import Codec.Picture -import Data.Monoid (mempty, (<>)) -import Network.HTTP.Req ((/:)) -import qualified Network.HTTP.Req as R -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as Q -import qualified Data.ByteString.Lazy.Char8 as QL -import qualified Data.ByteString.Base64 as B64 - -import Discord.Rest.Prelude -import Discord.Types - -instance Request (UserRequest a) where - majorRoute = userMajorRoute - jsonRequest = userJsonRequest - - --- | Data constructor for requests. See -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 -> CurrentUserAvatar -> 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] - --- | Formatted avatar data https://discordapp.com/developers/docs/resources/user#avatar-data -data CurrentUserAvatar = CurrentUserAvatar String - -parseCurrentUserAvatar :: Q.ByteString -> Either String CurrentUserAvatar -parseCurrentUserAvatar bs = - case decodeImage bs of - Left e -> Left e - Right im -> Right $ CurrentUserAvatar $ "data:image/png;base64," - <> Q.unpack (B64.encode (QL.toStrict (encodePng (convertRGBA8 im)))) - - -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 " - --- | The base url (Req) for API requests -baseUrl :: R.Url 'R.Https -baseUrl = R.https "discordapp.com" R./: "api" R./: apiVersion - where apiVersion = "v6" - -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 (CurrentUserAvatar im)) -> - Patch (users /: "@me") (R.ReqBodyJson (object [ "username" .= name - , "avatar" .= im ])) 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/src/Discord/Types.hs b/src/Discord/Types.hs --- a/src/Discord/Types.hs +++ b/src/Discord/Types.hs @@ -1,20 +1,5 @@ -{-# OPTIONS_HADDOCK prune, not-home #-} - --- | Provides types and encoding/decoding code. Types should be identical to those provided --- in the Discord API documentation. module Discord.Types - ( module Discord.Types.Prelude - , module Discord.Types.Channel - , module Discord.Types.Events - , module Discord.Types.Gateway - , module Discord.Types.Guild - , module Data.Aeson + ( module Discord.Internal.Types ) where -import Discord.Types.Channel -import Discord.Types.Events -import Discord.Types.Gateway -import Discord.Types.Guild -import Discord.Types.Prelude - -import Data.Aeson (Object) +import Discord.Internal.Types diff --git a/src/Discord/Types/Channel.hs b/src/Discord/Types/Channel.hs deleted file mode 100644 --- a/src/Discord/Types/Channel.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | Data structures pertaining to Discord Channels -module Discord.Types.Channel where - -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Default (Default, def) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock -import qualified Data.HashMap.Strict as HM -import qualified Data.Vector as V - -import Discord.Types.Prelude - --- | Represents information about a user. -data User = User - { userId :: UserId -- ^ The user's id. - , userName :: String -- ^ The user's username (not unique) - , userDiscrim :: String -- ^ The user's 4-digit discord-tag. - , userAvatar :: Maybe String -- ^ The user's avatar hash. - , userIsBot :: Bool -- ^ User is an OAuth2 application. - , userIsWebhook:: Bool -- ^ User is a webhook - , userMfa :: Maybe Bool -- ^ User has two factor authentication enabled on the account. - , userVerified :: Maybe Bool -- ^ Whether the email has been verified. - , userEmail :: Maybe String -- ^ The user's email. - } deriving (Show, Eq, Ord) - -instance FromJSON User where - parseJSON = withObject "User" $ \o -> - User <$> o .: "id" - <*> o .: "username" - <*> o .: "discriminator" - <*> o .:? "avatar" - <*> o .:? "bot" .!= False - <*> pure False -- webhook - <*> o .:? "mfa_enabled" - <*> o .:? "verified" - <*> o .:? "email" - - -data Webhook = Webhook - { webhookId :: WebhookId - , webhookToken :: Text - , webhookChannelId :: ChannelId - } deriving (Show, Eq, Ord) - -instance FromJSON Webhook where - parseJSON = withObject "Webhook" $ \o -> - Webhook <$> o .: "id" - <*> o .: "token" - <*> o .: "channel_id" - -data ConnectionObject = ConnectionObject - { connectionObjectId :: Text - , connectionObjectName :: Text - , connectionObjectType :: Text - , connectionObjectRevoked :: Bool - , connectionObjectIntegrations :: [IntegrationId] - , connectionObjectVerified :: Bool - , connectionObjectFriendSyncOn :: Bool - , connectionObjectShownInPresenceUpdates :: Bool - , connectionObjectVisibleToOthers :: Bool - } deriving (Show, Eq, Ord) - -instance FromJSON ConnectionObject where - parseJSON = withObject "ConnectionObject" $ \o -> do - integrations <- o .: "integrations" - ConnectionObject <$> o .: "id" - <*> o .: "name" - <*> o .: "type" - <*> o .: "revoked" - <*> sequence (map (.: "id") integrations) - <*> o .: "verified" - <*> o .: "friend_sync" - <*> o .: "show_activity" - <*> ( (==) (1::Int) <$> o .: "visibility") - - --- | 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 :: String -- ^ The name of the guild (2 - 1000 characters). - , channelPosition :: Integer -- ^ The storing position of the channel. - , channelPermissions :: [Overwrite] -- ^ An array of permission 'Overwrite's - , channelTopic :: String -- ^ The topic of the channel. (0 - 1024 chars). - , channelLastMessage :: Maybe MessageId -- ^ The id of the last message sent in the - -- channel - } - -- | A voice channel in a guild. - | ChannelVoice - { channelId :: ChannelId - , channelGuild :: GuildId - , channelName :: String - , channelPosition :: Integer - , channelPermissions :: [Overwrite] - , channelBitRate :: Integer -- ^ The bitrate (in bits) of the channel. - , channelUserLimit :: Integer -- ^ The user limit of the voice channel. - } - -- | DM Channels represent a one-to-one conversation between two users, outside the scope - -- of guilds - | ChannelDirectMessage - { channelId :: ChannelId - , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s). - , channelLastMessage :: Maybe MessageId - } - | ChannelGroupDM - { channelId :: ChannelId - , channelRecipients :: [User] - , channelLastMessage :: Maybe MessageId - } - | ChannelGuildCategory - { channelId :: ChannelId - , channelGuild :: GuildId - } deriving (Show, 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 .:? "topic" .!= "" - <*> o .:? "last_message_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 .: "bitrate" - <*> o .: "user_limit" - 3 -> - ChannelGroupDM <$> o .: "id" - <*> o .: "recipients" - <*> o .:? "last_message_id" - 4 -> - ChannelGuildCategory <$> o .: "id" - <*> o .:? "guild_id" .!= 0 - _ -> fail ("Unknown channel type:" <> show type') - --- | 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 - _ -> False - --- | Permission overwrites for a channel. -data Overwrite = Overwrite - { overwriteId :: OverwriteId -- ^ 'Role' or 'User' id - , overwriteType :: String -- ^ Either "role" or "member - , overwriteAllow :: Integer -- ^ Allowed permission bit set - , overwriteDeny :: Integer -- ^ Denied permission bit set - } deriving (Show, Eq, Ord) - -instance FromJSON Overwrite where - parseJSON = withObject "Overwrite" $ \o -> - Overwrite <$> o .: "id" - <*> o .: "type" - <*> o .: "allow" - <*> o .: "deny" - -instance ToJSON Overwrite where - toJSON Overwrite{..} = object - [ ("id", toJSON overwriteId) - , ("type", toJSON overwriteType) - , ("allow", toJSON overwriteAllow) - , ("deny", toJSON overwriteDeny) - ] - --- | Represents information about a message in a Discord channel. -data Message = Message - { messageId :: MessageId -- ^ The id of the message - , messageChannel :: ChannelId -- ^ Id of the channel the message - -- was sent in - , messageAuthor :: User -- ^ The 'User' the message was sent - -- by - , messageText :: 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 - , messageNonce :: Maybe Snowflake -- ^ Used for validating if a message - -- was sent - , messagePinned :: Bool -- ^ Whether this message is pinned - , messageGuild :: Maybe GuildId -- ^ The guild the message went to - } deriving (Show, Eq, Ord) - -instance FromJSON Message where - parseJSON = withObject "Message" $ \o -> - Message <$> o .: "id" - <*> o .: "channel_id" - <*> (do isW <- o .:? "webhook_id" - a <- o .: "author" - case isW :: Maybe WebhookId of - Nothing -> pure a - Just _ -> pure $ a { userIsWebhook = True }) - <*> 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 .:? "nonce" - <*> o .:? "pinned" .!= False - <*> o .:? "guild_id" .!= Nothing - --- | Represents an attached to a message file. -data Attachment = Attachment - { attachmentId :: Snowflake -- ^ Attachment id - , attachmentFilename :: String -- ^ Name of attached file - , attachmentSize :: Integer -- ^ Size of file (in bytes) - , attachmentUrl :: String -- ^ Source of file - , attachmentProxy :: String -- ^ Proxied url of file - , attachmentHeight :: Maybe Integer -- ^ Height of file (if image) - , attachmentWidth :: Maybe Integer -- ^ Width of file (if image) - } deriving (Show, 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" - --- | An embed attached to a message. -data Embed = Embed - { embedTitle :: Maybe String -- ^ Title of the embed - , embedType :: Maybe String -- ^ Type of embed (Always "rich" for webhooks) - , embedDescription :: Maybe String -- ^ Description of embed - , embedUrl :: Maybe String -- ^ URL of embed - , embedTimestamp :: Maybe UTCTime -- ^ The time of the embed content - , embedColor :: Maybe Integer -- ^ The embed color - , embedFields :: [SubEmbed] -- ^ Fields of the embed - } deriving (Show, Eq, Ord) - -instance Default Embed where - def = Embed - { embedTitle = Nothing - , embedType = Nothing - , embedDescription = Nothing - , embedUrl = Nothing - , embedTimestamp = Nothing - , embedColor = Nothing - , embedFields = [] - } - -instance FromJSON Embed where - parseJSON = withObject "Embed" $ \o -> - Embed <$> o .:? "title" - <*> o .:? "type" - <*> o .:? "description" - <*> o .:? "url" - <*> o .:? "timestamp" - <*> o .:? "color" - <*> sequence (HM.foldrWithKey to_embed [] o) - where - to_embed k (Object v) a = case k of - "footer" -> (Footer <$> v .: "text" - <*> v .:? "icon_url" .!= "" - <*> v .:? "proxy_icon_url" .!= "") : a - "image" -> (Image <$> v .: "url" - <*> v .: "proxy_url" - <*> v .: "height" - <*> v .: "width") : a - "thumbnail" -> (Thumbnail <$> v .: "url" - <*> v .: "proxy_url" - <*> v .: "height" - <*> v .: "width") : a - "video" -> (Video <$> v .: "url" - <*> v .: "height" - <*> v .: "width") : a - "provider" -> (Provider <$> v .: "name" - <*> v .:? "url" .!= "") : a - "author" -> (Author <$> v .: "name" - <*> v .:? "url" .!= "" - <*> v .:? "icon_url" .!= "" - <*> v .:? "proxy_icon_url" .!= "") : a - _ -> a - to_embed k (Array v) a = case k of - "fields" -> [Field <$> i .: "name" - <*> i .: "value" - <*> i .: "inline" - | Object i <- V.toList v] ++ a - _ -> a - to_embed _ _ a = a - -instance ToJSON Embed where - toJSON (Embed {..}) = object - [ "title" .= embedTitle - , "type" .= embedType - , "description" .= embedDescription - , "url" .= embedUrl - , "timestamp" .= embedTimestamp - , "color" .= embedColor - ] |> makeSubEmbeds embedFields - where - (|>) :: Value -> HM.HashMap Text Value -> Value - (|>) (Object o) hm = Object $ HM.union o hm - (|>) _ _ = error "Type mismatch" - - makeSubEmbeds :: [SubEmbed] -> HM.HashMap Text Value - makeSubEmbeds = foldr embed HM.empty - - embed :: SubEmbed -> HM.HashMap Text Value -> HM.HashMap Text Value - embed (Thumbnail url _ height width) = - HM.alter (\_ -> Just $ object - [ "url" .= url - , "height" .= height - , "width" .= width - ]) "thumbnail" - embed (Image url _ height width) = - HM.alter (\_ -> Just $ object - [ "url" .= url - , "height" .= height - , "width" .= width - ]) "image" - embed (Author name url icon _) = - HM.alter (\_ -> Just $ object - [ "name" .= name - , "url" .= url - , "icon_url" .= icon - ]) "author" - embed (Footer text icon _) = - HM.alter (\_ -> Just $ object - [ "text" .= text - , "icon_url" .= icon - ]) "footer" - embed (Field name value inline) = - HM.alter (\val -> case val of - Just (Array a) -> Just . Array $ V.cons (object - [ "name" .= name - , "value" .= value - , "inline" .= inline - ]) a - _ -> Just $ toJSON [ - object - [ "name" .= name - , "value" .= value - , "inline" .= inline - ] - ] - ) "fields" - embed _ = id - --- | Represents a part of an embed. -data SubEmbed - = Thumbnail - String - String - Integer - Integer - | Video - String - Integer - Integer - | Image - String - String - Integer - Integer - | Provider - String - String - | Author - String - String - String - String - | Footer - String - String - String - | Field - String - String - Bool - deriving (Show, Eq, Ord) diff --git a/src/Discord/Types/Events.hs b/src/Discord/Types/Events.hs deleted file mode 100644 --- a/src/Discord/Types/Events.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Data structures pertaining to gateway dispatch 'Event's -module Discord.Types.Events where - -import Prelude hiding (id) - -import Data.Time.ISO8601 (parseISO8601) -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Text as T - -import Discord.Types.Prelude -import Discord.Types.Channel -import Discord.Types.Guild (Guild, GuildUnavailable, GuildInfo, - GuildMember, Role, Emoji) - - --- | Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway. -data Event = - Ready Int User [Channel] [GuildUnavailable] String - | Resumed [T.Text] - | ChannelCreate Channel - | ChannelUpdate Channel - | ChannelDelete Channel - | ChannelPinsUpdate ChannelId (Maybe UTCTime) - | GuildCreate Guild GuildInfo - | GuildUpdate Guild - | GuildDelete GuildUnavailable - | GuildBanAdd GuildId User - | GuildBanRemove GuildId User - | GuildEmojiUpdate GuildId [Emoji] - | GuildIntegrationsUpdate GuildId - | GuildMemberAdd GuildId GuildMember - | GuildMemberRemove GuildId User - | GuildMemberUpdate GuildId [RoleId] User (Maybe String) - | GuildMemberChunk GuildId [GuildMember] - | GuildRoleCreate GuildId Role - | GuildRoleUpdate GuildId Role - | GuildRoleDelete GuildId RoleId - | MessageCreate Message - | MessageUpdate ChannelId MessageId - | MessageDelete ChannelId MessageId - | MessageDeleteBulk ChannelId [MessageId] - | MessageReactionAdd ReactionInfo - | MessageReactionRemove ReactionInfo - | MessageReactionRemoveAll ChannelId MessageId - | PresenceUpdate PresenceInfo - | TypingStart TypingInfo - | UserUpdate User - -- | VoiceStateUpdate - -- | VoiceServerUpdate - | UnknownEvent String Object - deriving (Show, Eq) - -data ReactionInfo = ReactionInfo - { reactionUserId :: UserId - , reactionChannelId :: ChannelId - , reactionMessageId :: MessageId - , reactionEmoji :: Emoji - } deriving (Show, Eq, Ord) - -instance FromJSON ReactionInfo where - parseJSON = withObject "ReactionInfo" $ \o -> - ReactionInfo <$> o .: "user_id" - <*> o .: "channel_id" - <*> o .: "message_id" - <*> o .: "emoji" - -data PresenceInfo = PresenceInfo - { presenceUserId :: UserId - , presenceRoles :: [RoleId] - -- , presenceGame :: Maybe Activity - , presenceGuildId :: GuildId - , presenceStatus :: String - } deriving (Show, Eq, Ord) - -instance FromJSON PresenceInfo where - parseJSON = withObject "PresenceInfo" $ \o -> - PresenceInfo <$> (o .: "user" >>= (.: "id")) - <*> o .: "roles" - -- <*> o .: "game" - <*> o .: "guild_id" - <*> o .: "status" - -data TypingInfo = TypingInfo - { typingUserId :: UserId - , typingChannelId :: ChannelId - , typingTimestamp :: UTCTime - } deriving (Show, 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 - -eventParse :: T.Text -> Object -> Parser Event -eventParse t o = case t of - "READY" -> Ready <$> o .: "v" - <*> o .: "user" - <*> o .: "private_channels" - <*> o .: "guilds" - <*> o .: "session_id" - "RESUMED" -> Resumed <$> o .: "_trace" - "CHANNEL_CREATE" -> ChannelCreate <$> reparse o - "CHANNEL_UPDATE" -> ChannelUpdate <$> reparse o - "CHANNEL_DELETE" -> ChannelDelete <$> reparse o - "CHANNEL_PINS_UPDATE" -> do id <- o .: "channel_id" - stamp <- o .:? "last_pin_timestamp" - let utc = stamp >>= parseISO8601 - pure (ChannelPinsUpdate id utc) - "GUILD_CREATE" -> GuildCreate <$> reparse o <*> reparse o - "GUILD_UPDATE" -> GuildUpdate <$> reparse o - "GUILD_DELETE" -> GuildDelete <$> reparse o - "GUILD_BAN_ADD" -> GuildBanAdd <$> o .: "guild_id" <*> o .: "user" - "GUILD_BAN_REMOVE" -> GuildBanRemove <$> o .: "guild_id" <*> o .: "user" - "GUILD_EMOJI_UPDATE" -> GuildEmojiUpdate <$> o .: "guild_id" <*> o .: "emojis" - "GUILD_INTEGRATIONS_UPDATE" -> GuildIntegrationsUpdate <$> o .: "guild_id" - "GUILD_MEMBER_ADD" -> GuildMemberAdd <$> o .: "guild_id" <*> reparse o - "GUILD_MEMBER_REMOVE" -> GuildMemberRemove <$> o .: "guild_id" <*> o .: "user" - "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> o .: "guild_id" - <*> o .: "roles" - <*> o .: "user" - <*> o .:? "nick" - "GUILD_MEMBER_CHUNK" -> GuildMemberChunk <$> o .: "guild_id" <*> o .: "members" - "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> o .: "guild_id" <*> o .: "role" - "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> o .: "guild_id" <*> o .: "role" - "GUILD_ROLE_DELETE" -> GuildRoleDelete <$> o .: "guild_id" <*> o .: "role_id" - "MESSAGE_CREATE" -> MessageCreate <$> reparse o - "MESSAGE_UPDATE" -> MessageUpdate <$> o .: "channel_id" <*> o .: "id" - "MESSAGE_DELETE" -> MessageDelete <$> o .: "channel_id" <*> o .: "id" - "MESSAGE_DELETE_BULK" -> MessageDeleteBulk <$> o .: "channel_id" <*> o .: "ids" - "MESSAGE_REACTION_ADD" -> MessageReactionAdd <$> reparse o - "MESSAGE_REACTION_REMOVE" -> MessageReactionRemove <$> reparse o - "MESSAGE_REACTION_REMOVE_ALL" -> MessageReactionRemoveAll <$> o .: "channel_id" - <*> o .: "message_id" - "PRESENCE_UPDATE" -> PresenceUpdate <$> reparse o - "TYPING_START" -> TypingStart <$> reparse o - "USER_UPDATE" -> UserUpdate <$> reparse o - -- "VOICE_STATE_UPDATE" -> VoiceStateUpdate <$> reparse o - -- "VOICE_SERVER_UPDATE" -> VoiceServerUpdate <$> reparse o - _other_event -> UnknownEvent (T.unpack t) <$> reparse o diff --git a/src/Discord/Types/Gateway.hs b/src/Discord/Types/Gateway.hs deleted file mode 100644 --- a/src/Discord/Types/Gateway.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} - --- | Data structures needed for interfacing with the Websocket --- Gateway -module Discord.Types.Gateway where - -import System.Info - -import qualified Data.Text as T -import Data.Monoid ((<>)) -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Aeson -import Data.Aeson.Types -import Data.Maybe (fromMaybe) -import Text.Read (readMaybe) - -import Discord.Types.Prelude -import Discord.Types.Events - --- | Represents data sent and received with Discord servers -data GatewayReceivable - = Dispatch Event Integer - | HeartbeatRequest Integer - | Reconnect - | InvalidSession Bool - | Hello Int - | HeartbeatAck - | ParseError String - deriving (Show, Eq) - -data GatewaySendable - = Heartbeat Integer - | Identify Auth Bool Integer (Int, Int) - | Resume T.Text String Integer - | RequestGuildMembers RequestGuildMembersOpts - | UpdateStatus UpdateStatusOpts - | UpdateStatusVoice UpdateStatusVoiceOpts - deriving (Show, Eq, Ord) - -data RequestGuildMembersOpts = RequestGuildMembersOpts - { requestGuildMembersGuildId :: GuildId - , requestGuildMembersSearchQuery :: T.Text - , requestGuildMembersLimit :: Integer } - deriving (Show, Eq, Ord) - -data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts - { updateStatusVoiceGuildId :: GuildId - , updateStatusVoiceChannelId :: Maybe ChannelId - , updateStatusVoiceIsMuted :: Bool - , updateStatusVoiceIsDeaf :: Bool - } - deriving (Show, Eq, Ord) - -data UpdateStatusOpts = UpdateStatusOpts - { updateStatusSince :: Maybe UTCTime - , updateStatusGame :: Maybe Activity - , updateStatusNewStatus :: UpdateStatusType - , updateStatusAFK :: Bool - } - deriving (Show, Eq, Ord) - -data Activity = Activity - { activityName :: T.Text - , activityType :: ActivityType - , activityUrl :: Maybe T.Text - } - deriving (Show, Eq, Ord) - -data ActivityType = ActivityTypeGame - | ActivityTypeStreaming - | ActivityTypeListening - | ActivityTypeWatching - deriving (Show, Eq, Ord, Enum) - -data UpdateStatusType = UpdateStatusOnline - | UpdateStatusDoNotDisturb - | UpdateStatusAwayFromKeyboard - | UpdateStatusInvisibleOffline - | UpdateStatusOffline - deriving (Show, Eq, Ord, Enum) - -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 (UnknownEvent ("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 GatewaySendable where - toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= if i <= 0 then "null" else show i ] - toJSON (Identify token compress large shard) = object [ - "op" .= (2 :: Int) - , "d" .= object [ - "token" .= authToken token - , "properties" .= object [ - "$os" .= os - , "$browser" .= ("discord-haskell" :: String) - , "$device" .= ("discord-haskell" :: String) - , "$referrer" .= ("" :: String) - , "$referring_domain" .= ("" :: String) - ] - , "compress" .= compress - , "large_threshold" .= large - , "shard" .= shard - ] - ] - toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [ - "op" .= (3 :: Int) - , "d" .= object [ - "since" .= case since of Nothing -> Nothing - Just s -> Just ((10^6) * (utcTimeToPOSIXSeconds s)) - , "afk" .= afk - , "status" .= statusString status - , "game" .= case game of Nothing -> Nothing - Just a -> Just $ object [ - "name" .= activityName a - , "type" .= (fromEnum $ activityType a :: Int) - , "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 (Resume token session seqId) = object [ - "op" .= (6 :: Int) - , "d" .= object [ - "token" .= token - , "session_id" .= session - , "seq" .= seqId - ] - ] - toJSON (RequestGuildMembers (RequestGuildMembersOpts guild query limit)) = - object [ - "op" .= (8 :: Int) - , "d" .= object [ - "guild_id" .= guild - , "query" .= query - , "limit" .= limit - ] - ] diff --git a/src/Discord/Types/Guild.hs b/src/Discord/Types/Guild.hs deleted file mode 100644 --- a/src/Discord/Types/Guild.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Types relating to Discord Guilds (servers) -module Discord.Types.Guild where - -import Data.Time.Clock - -import Data.Aeson -import qualified Data.Text as T - -import Discord.Types.Channel -import Discord.Types.Prelude - --- | Representation of a guild member. -data GuildMember = GuildMember - { memberUser :: User - , memberNick :: Maybe T.Text - , memberRoles :: [Snowflake] - , memberJoinedAt :: UTCTime - , memberDeaf :: Bool - , memberMute :: Bool - } deriving (Show, Eq, Ord) - -instance FromJSON GuildMember where - parseJSON = withObject "GuildMember" $ \o -> - GuildMember <$> o .: "user" - <*> o .:? "nick" - <*> o .: "roles" - <*> o .: "joined_at" - <*> o .: "deaf" - <*> o .: "mute" - - --- https://discordapp.com/developers/docs/resources/guild#guild-object - --- | Guilds in Discord represent a collection of users and channels into an isolated --- "Server" -data Guild = Guild - { guildId :: GuildId -- ^ Gulid id - , guildName :: T.Text -- ^ Guild name (2 - 100 chars) - , guildIcon :: Maybe T.Text -- ^ Icon hash - , guildSplash :: Maybe T.Text -- ^ Splash hash - , guildOwnerId :: UserId -- ^ Guild owner id - , guildPermissions :: Maybe Integer - , guildRegion :: T.Text -- ^ Guild voice region - , guildAfkId :: Maybe ChannelId -- ^ Id of afk channel - , guildAfkTimeout :: Integer -- ^ Afk timeout in seconds - , guildEmbedEnabled :: Maybe Bool -- ^ Id of embedded channel - , guildEmbedChannel :: Maybe ChannelId -- ^ Id of embedded channel - , guildVerificationLevel :: Integer -- ^ Level of verification - , guildNotification :: Integer -- ^ Level of default notifications - , guildExplicitFilterLevel :: Integer - , guildRoles :: [Role] -- ^ Array of 'Role' objects - , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects - , guildFeatures :: [T.Text] - , guildMultiFactAuth :: !Integer - , guildApplicationId :: Maybe Snowflake - } deriving (Show, Eq, Ord) - -instance FromJSON Guild where - parseJSON = withObject "Guild" $ \o -> - Guild <$> o .: "id" - <*> o .: "name" - <*> o .:? "icon" - <*> o .:? "splash" - <*> o .: "owner_id" - <*> o .:? "permissions" - <*> o .: "region" - <*> o .:? "afk_channel_id" - <*> o .: "afk_timeout" - <*> o .:? "embed_enabled" - <*> o .:? "embed_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" - -data GuildUnavailable = GuildUnavailable - { idOnceAvailable :: GuildId - } deriving (Show, Eq, Ord) - -instance FromJSON GuildUnavailable where - parseJSON = withObject "GuildUnavailable" $ \o -> - GuildUnavailable <$> o .: "id" - -data GuildInfo = GuildInfo - { guildJoinedAt :: UTCTime - , guildLarge :: Bool - , guildMemberCount :: Integer - -- , guildVoiceStates :: [VoiceState] -- (without guildid) todo have to add voice state data type - , guildMembers :: [GuildMember] - , guildChannels :: [Channel] -- ^ Channels in the guild (sent in GuildCreate) - -- , guildPresences :: [Presence] - } deriving (Show, Eq, Ord) - -instance FromJSON GuildInfo where - parseJSON = withObject "GuildInfo" $ \o -> - GuildInfo <$> o .: "joined_at" - <*> o .: "large" - <*> o .: "member_count" - -- <*> o .: "voice_states" - <*> o .: "members" - <*> o .: "channels" - -data PartialGuild = PartialGuild - { partialGuildId :: GuildId - , partialGuildName :: T.Text - , partialGuildIcon :: Maybe T.Text - , partialGuildOwner :: Bool - , partialGuildPermissions :: Integer - } deriving (Show, Eq, Ord) - -instance FromJSON PartialGuild where - parseJSON = withObject "PartialGuild" $ \o -> - PartialGuild <$> o .: "id" - <*> o .: "name" - <*> o .:? "icon" - <*> o .:? "owner" .!= False - <*> o .: "permissions" - --- | Represents an emoticon (emoji) -data Emoji = Emoji - { emojiId :: Maybe EmojiId -- ^ The emoji id - , emojiName :: T.Text -- ^ The emoji name - , emojiRoles :: Maybe [RoleId] -- ^ Roles the emoji is active for - , emojiManaged :: Maybe Bool -- ^ Whether this emoji is managed - } deriving (Show, Eq, Ord) - -instance FromJSON Emoji where - parseJSON = withObject "Emoji" $ \o -> - Emoji <$> o .: "id" - <*> o .: "name" - <*> o .:? "roles" - <*> o .:? "managed" - --- | 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 :: Integer -- ^ Integer representation of color code - , roleHoist :: Bool -- ^ If the role is pinned in the user listing - , rolePos :: Integer -- ^ Position of this role - , rolePerms :: Integer -- ^ Permission bit set - , roleManaged :: Bool -- ^ Whether this role is managed by an integration - , roleMention :: Bool -- ^ Whether this role is mentionable - } deriving (Show, 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" - --- | 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 - , voiceRegionDepreciated :: Bool -- ^ Whether this is a deprecated region - , voiceRegionCustom :: Bool -- ^ Whether this is a custom region - } deriving (Show, 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 Ban = Ban - { banReason :: T.Text - , banUser :: User - } deriving (Show, Eq, Ord) - -instance FromJSON Ban where - parseJSON = withObject "Ban" $ \o -> Ban <$> 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, 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, 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, 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, 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 GuildEmbed = GuildEmbed - { embedEnabled :: Bool -- ^ Whether the embed is enabled - , embedChannel :: ChannelId -- ^ The embed channel id - } deriving (Show, Eq, Ord) - -instance FromJSON GuildEmbed where - parseJSON = withObject "GuildEmbed" $ \o -> - GuildEmbed <$> o .: "enabled" <*> o .: "snowflake" - -instance ToJSON GuildEmbed where - toJSON (GuildEmbed enabled snowflake) = object - [ "enabled" .= enabled - , "snowflake" .= snowflake - ] diff --git a/src/Discord/Types/Prelude.hs b/src/Discord/Types/Prelude.hs deleted file mode 100644 --- a/src/Discord/Types/Prelude.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides base types and utility functions needed for modules in Discord.Types -module Discord.Types.Prelude where - -import Data.Bits -import Data.Word - -import Data.Aeson.Types -import Data.Time.Clock -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.ByteString.Char8 as Q -import Data.Time.Clock.POSIX -import Data.Monoid ((<>)) -import Control.Monad (mzero) - --- | Authorization token for the Discord API -data Auth = Auth T.Text - deriving (Show, Eq, Ord) - - --- | Formats the token for use with the REST API -formatAuth :: Auth -> Q.ByteString -formatAuth (Auth givenTok) = let token = T.strip givenTok - bot = if "Bot " `T.isPrefixOf` token then "" else "Bot " - in TE.encodeUtf8 $ bot <> token - --- | Get the raw token formatted for use with the websocket gateway -authToken :: Auth -> T.Text -authToken (Auth token) = token - --- | A unique integer identifier. Can be used to calculate the creation date of an entity. -newtype Snowflake = Snowflake Word64 - deriving (Ord, Eq, Num, Integral, Enum, Real, Bits) - -instance Show Snowflake where - show (Snowflake a) = show a - -instance ToJSON Snowflake where - toJSON (Snowflake snowflake) = String . T.pack $ show snowflake - -instance FromJSON Snowflake where - parseJSON (String snowflake) = Snowflake <$> (return . read $ T.unpack snowflake) - parseJSON _ = mzero - -type ChannelId = Snowflake -type GuildId = Snowflake -type MessageId = Snowflake -type EmojiId = Snowflake -type UserId = Snowflake -type OverwriteId = Snowflake -type RoleId = Snowflake -type IntegrationId = Snowflake -type WebhookId = Snowflake - --- | 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 -