discord-haskell 0.8.4 → 1.0.0
raw patch · 43 files changed
+3292/−2949 lines, 43 filesdep +discord-haskelldep +emojidep ~basedep ~textnew-component:exe:ping-pong
Dependencies added: discord-haskell, emoji
Dependency ranges changed: base, text
Files
- README.md +28/−102
- changelog.md +7/−0
- discord-haskell.cabal +35/−19
- examples/ping-pong.hs +61/−0
- src/Discord.hs +142/−97
- src/Discord/Gateway.hs +0/−41
- src/Discord/Gateway/Cache.hs +0/−81
- src/Discord/Gateway/EventLoop.hs +0/−219
- src/Discord/Handle.hs +25/−0
- src/Discord/Internal/Gateway.hs +39/−0
- src/Discord/Internal/Gateway/Cache.hs +75/−0
- src/Discord/Internal/Gateway/EventLoop.hs +215/−0
- src/Discord/Internal/Rest.hs +48/−0
- src/Discord/Internal/Rest/Channel.hs +325/−0
- src/Discord/Internal/Rest/Emoji.hs +110/−0
- src/Discord/Internal/Rest/Guild.hs +465/−0
- src/Discord/Internal/Rest/HTTP.hs +137/−0
- src/Discord/Internal/Rest/Invite.hs +49/−0
- src/Discord/Internal/Rest/Prelude.hs +57/−0
- src/Discord/Internal/Rest/User.hs +107/−0
- src/Discord/Internal/Rest/Voice.hs +41/−0
- src/Discord/Internal/Rest/Webhook.hs +148/−0
- src/Discord/Internal/Types.hs +18/−0
- src/Discord/Internal/Types/Channel.hs +455/−0
- src/Discord/Internal/Types/Events.hs +155/−0
- src/Discord/Internal/Types/Gateway.hs +181/−0
- src/Discord/Internal/Types/Guild.hs +290/−0
- src/Discord/Internal/Types/Prelude.hs +60/−0
- src/Discord/Requests.hs +17/−0
- src/Discord/Rest.hs +0/−48
- src/Discord/Rest/Channel.hs +0/−321
- src/Discord/Rest/Emoji.hs +0/−109
- src/Discord/Rest/Guild.hs +0/−450
- src/Discord/Rest/HTTP.hs +0/−134
- src/Discord/Rest/Invite.hs +0/−49
- src/Discord/Rest/Prelude.hs +0/−55
- src/Discord/Rest/User.hs +0/−106
- src/Discord/Types.hs +2/−17
- src/Discord/Types/Channel.hs +0/−408
- src/Discord/Types/Events.hs +0/−156
- src/Discord/Types/Gateway.hs +0/−181
- src/Discord/Types/Guild.hs +0/−290
- src/Discord/Types/Prelude.hs +0/−66
README.md view
@@ -1,112 +1,38 @@ # discord-haskell [](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:-<https://discordapp.com/developers/applications>.--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 `<information>` below.-Client ID and Permissions come from previous steps.-`https://discordapp.com/oauth2/authorize?client_id=<CLIENT_ID>&scope=bot&permissions=<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: <most recent stable 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 `<name:id_number>` 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-
changelog.md view
@@ -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
discord-haskell.cabal view
@@ -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 <https://discordapp.com/developers/docs/reference>. .- See the project readme for quickstart notes- <https://github.com/aquarial/discord-haskell#discord-haskell>+ See the project wiki for quickstart notes+ <https://github.com/aquarial/discord-haskell/wiki> 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
+ examples/ping-pong.hs view
@@ -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
src/Discord.hs view
@@ -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 ()+
− src/Discord/Gateway.hs
@@ -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)---
− src/Discord/Gateway/Cache.hs
@@ -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
− src/Discord/Gateway/EventLoop.hs
@@ -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)
+ src/Discord/Handle.hs view
@@ -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+ }
+ src/Discord/Internal/Gateway.hs view
@@ -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)+++
+ src/Discord/Internal/Gateway/Cache.hs view
@@ -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
+ src/Discord/Internal/Gateway/EventLoop.hs view
@@ -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)
+ src/Discord/Internal/Rest.hs view
@@ -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++
+ src/Discord/Internal/Rest/Channel.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+data ChannelRequest a where+ -- | Gets a channel by its id.+ GetChannel :: ChannelId -> ChannelRequest Channel+ -- | Edits channels options.+ ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel+ -- | Deletes a channel if its id doesn't equal to the id of guild.+ DeleteChannel :: ChannelId -> ChannelRequest Channel+ -- | Gets a messages from a channel with limit of 100 per request.+ GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message]+ -- | Gets a message in a channel by its id.+ GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message+ -- | Sends a message to a channel.+ CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message+ -- | Sends a message with 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 <https://discordapp.com/developers/docs/resources/channel#get-channel-messages>+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+
+ src/Discord/Internal/Rest/Emoji.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+data EmojiRequest a where+ -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission.+ ListGuildEmojis :: GuildId -> EmojiRequest [Emoji]+ -- | Emoji object for the given guild and emoji ID+ GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji+ -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission.+ CreateGuildEmoji :: GuildId -> T.Text -> 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
+ src/Discord/Internal/Rest/Guild.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+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
+ src/Discord/Internal/Rest/HTTP.hs view
@@ -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)
+ src/Discord/Internal/Rest/Invite.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+data InviteRequest a where+ -- | Get invite for given code+ GetInvite :: T.Text -> InviteRequest Invite+ -- | Delete invite by code+ DeleteInvite :: T.Text -> InviteRequest Invite++inviteMajorRoute :: InviteRequest a -> String+inviteMajorRoute c = case c of+ (GetInvite _) -> "invite "+ (DeleteInvite _) -> "invite "++-- | 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
+ src/Discord/Internal/Rest/Prelude.hs view
@@ -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 }
+ src/Discord/Internal/Rest/User.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+data UserRequest a where+ -- | Returns the 'User' object of the requester's account. For OAuth2, this requires+ -- the identify scope, which will return the object without an email, and optionally+ -- the email scope, which returns the object with an email.+ GetCurrentUser :: UserRequest User+ -- | Returns a 'User' for a given user ID+ GetUser :: UserId -> UserRequest User+ -- | Modify user's username & avatar pic+ ModifyCurrentUser :: T.Text -> 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
+ src/Discord/Internal/Rest/Voice.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+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
+ src/Discord/Internal/Rest/Webhook.hs view
@@ -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 <https://discordapp.com/developers/docs/resources/ API>+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
+ src/Discord/Internal/Types.hs view
@@ -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)
+ src/Discord/Internal/Types/Channel.hs view
@@ -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)
+ src/Discord/Internal/Types/Events.hs view
@@ -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
+ src/Discord/Internal/Types/Gateway.hs view
@@ -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+ ]+ ]
+ src/Discord/Internal/Types/Guild.hs view
@@ -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+ ]
+ src/Discord/Internal/Types/Prelude.hs view
@@ -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+
+ src/Discord/Requests.hs view
@@ -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
− src/Discord/Rest.hs
@@ -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--
− src/Discord/Rest/Channel.hs
@@ -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 <https://discordapp.com/developers/docs/resources/ API>-data ChannelRequest a where- -- | Gets a channel by its id.- GetChannel :: ChannelId -> ChannelRequest Channel- -- | Edits channels options.- ModifyChannel :: ChannelId -> ModifyChannelOpts -> ChannelRequest Channel- -- | Deletes a channel if its id doesn't equal to the id of guild.- DeleteChannel :: ChannelId -> ChannelRequest Channel- -- | Gets a messages from a channel with limit of 100 per request.- GetChannelMessages :: ChannelId -> (Int, MessageTiming) -> ChannelRequest [Message]- -- | Gets a message in a channel by its id.- GetChannelMessage :: (ChannelId, MessageId) -> ChannelRequest Message- -- | Sends a message to a channel.- CreateMessage :: ChannelId -> T.Text -> ChannelRequest Message- -- | Sends a message with 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 <https://discordapp.com/developers/docs/resources/channel#get-channel-messages>-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-
− src/Discord/Rest/Emoji.hs
@@ -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 <https://discordapp.com/developers/docs/resources/ API>-data EmojiRequest a where- -- | List of emoji objects for the given guild. Requires MANAGE_EMOJIS permission.- ListGuildEmojis :: GuildId -> EmojiRequest [Emoji]- -- | Emoji object for the given guild and emoji ID- GetGuildEmoji :: GuildId -> EmojiId -> EmojiRequest Emoji- -- | Create a new guild emoji (static&animated). Requires MANAGE_EMOJIS permission.- CreateGuildEmoji :: GuildId -> T.Text -> 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
− src/Discord/Rest/Guild.hs
@@ -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 <https://discordapp.com/developers/docs/resources/ API>-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
− src/Discord/Rest/HTTP.hs
@@ -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)
− src/Discord/Rest/Invite.hs
@@ -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 <https://discordapp.com/developers/docs/resources/ API>-data InviteRequest a where- -- | Get invite for given code- GetInvite :: T.Text -> InviteRequest Invite- -- | Delete invite by code- DeleteInvite :: T.Text -> InviteRequest Invite--inviteMajorRoute :: InviteRequest a -> String-inviteMajorRoute c = case c of- (GetInvite _) -> "invite "- (DeleteInvite _) -> "invite "---- | 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
− src/Discord/Rest/Prelude.hs
@@ -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 }
− src/Discord/Rest/User.hs
@@ -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 <https://discordapp.com/developers/docs/resources/ API>-data UserRequest a where- -- | Returns the 'User' object of the requester's account. For OAuth2, this requires- -- the identify scope, which will return the object without an email, and optionally- -- the email scope, which returns the object with an email.- GetCurrentUser :: UserRequest User- -- | Returns a 'User' for a given user ID- GetUser :: UserId -> UserRequest User- -- | Modify user's username & avatar pic- ModifyCurrentUser :: T.Text -> 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
src/Discord/Types.hs view
@@ -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
− src/Discord/Types/Channel.hs
@@ -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)
− src/Discord/Types/Events.hs
@@ -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
− src/Discord/Types/Gateway.hs
@@ -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- ]- ]
− src/Discord/Types/Guild.hs
@@ -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- ]
− src/Discord/Types/Prelude.hs
@@ -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-