discord-haskell (empty) → 0.5.0
raw patch · 19 files changed
+2415/−0 lines, 19 filesdep +MonadRandomdep +aesondep +async
Dependencies added: MonadRandom, aeson, async, base, bytestring, containers, data-default, http-client, iso8601-time, req, safe-exceptions, text, time, unordered-containers, vector, websockets, wuss
Files
- LICENSE +20/−0
- discord-haskell.cabal +62/−0
- src/Discord.hs +103/−0
- src/Discord/Gateway.hs +43/−0
- src/Discord/Gateway/Cache.hs +70/−0
- src/Discord/Gateway/EventLoop.hs +183/−0
- src/Discord/Rest.hs +47/−0
- src/Discord/Rest/Channel.hs +257/−0
- src/Discord/Rest/Emoji.hs +74/−0
- src/Discord/Rest/Guild.hs +273/−0
- src/Discord/Rest/HTTP.hs +112/−0
- src/Discord/Rest/Prelude.hs +55/−0
- src/Discord/Rest/User.hs +82/−0
- src/Discord/Types.hs +20/−0
- src/Discord/Types/Channel.hs +355/−0
- src/Discord/Types/Events.hs +156/−0
- src/Discord/Types/Gateway.hs +161/−0
- src/Discord/Types/Guild.hs +288/−0
- src/Discord/Types/Prelude.hs +54/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Joshua Koike++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ discord-haskell.cabal view
@@ -0,0 +1,62 @@+name: discord-haskell+-- library version is also noted at src/Discord/Rest/Prelude.hs+version: 0.5.0+synopsis: Discord bot library for Haskell+description: Functions and data types to write discord bots.+ See docs: <https://discordapp.com/developers/docs/reference>+homepage: https://github.com/aquarial/discord-haskell+license: MIT+license-file: LICENSE+author: Karl+maintainer: ksfish5@gmail.com+-- copyright:+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ ghc-options: -Wall+ -fno-warn-type-defaults+ hs-source-dirs: src+ 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.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+ build-depends:+ base >=4.10.1.0 && <4.11+ , aeson >=1.2.4.0 && <1.3+ , async >=2.1.1.1 && <2.2+ , bytestring >=0.10.8.2 && <0.11+ , containers >=0.5.10.2 && <0.6+ , data-default >=0.7.1.1 && <0.8+ , http-client >=0.5.12.1 && <0.6+ , iso8601-time >=0.1.4 && <0.2+ , MonadRandom >=0.5.1 && <0.6+ , req >=1.0.0 && <1.1+ , safe-exceptions >=0.1.7.0 && <0.2+ , text >=1.2.3.0 && <1.3+ , time >=1.8.0.2 && <1.9+ , unordered-containers >=0.2.9.0 && <0.3+ , vector >=0.12.0.1 && <0.13+ , websockets >=0.12.4.1 && <0.13+ , wuss >=1.1.9 && <1.2++source-repository head+ type : git+ location: https://github.com/aquarial/discord-haskell
+ src/Discord.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE RankNTypes #-}++module Discord+ ( module Discord.Types+ , module Discord.Rest.Channel+ , module Discord.Rest.Guild+ , module Discord.Rest.User+ , module Discord.Rest.Emoji+ , Cache(..)+ , Gateway(..)+ , RestChan(..)+ , Request(..)+ , restCall+ , nextEvent+ , sendCommand+ , readCache+ , stopDiscord+ , loginRest+ , loginRestGateway+ ) where++import Prelude hiding (log)+import Control.Monad (forever)+import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Data.Monoid ((<>))+import Data.Aeson++import Discord.Rest+import Discord.Rest.Channel+import Discord.Rest.Guild+import Discord.Rest.User+import Discord.Rest.Emoji+import Discord.Types+import Discord.Gateway+import Discord.Gateway.Cache++-- | 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++-- | Start HTTP rest handler background threads+loginRest :: Auth -> IO (RestChan, NotLoggedIntoGateway, [ThreadIdType])+loginRest auth = do+ log <- newChan+ logId <- forkIO (logger log True)+ (restHandler, restId) <- createHandler auth log+ pure (restHandler, NotLoggedIntoGateway, [ ThreadLogger logId+ , ThreadRest restId+ ])++-- | Start HTTP rest handler and gateway background threads+loginRestGateway :: Auth -> IO (RestChan, Gateway, [ThreadIdType])+loginRestGateway auth = do+ log <- newChan+ logId <- forkIO (logger log True)+ (restHandler, restId) <- createHandler auth log+ (gate, gateId) <- startGatewayThread auth log+ pure (restHandler, gate, [ ThreadLogger logId+ , ThreadRest restId+ , ThreadGateway gateId+ ])++-- | Execute one http request and get a response+restCall :: (FromJSON a, Request (r a)) => (RestChan, y, z) -> r a -> IO (Either String a)+restCall (r,_,_) = writeRestCall r++-- | Block until the gateway produces another event+nextEvent :: (x, Gateway, z) -> IO Event+nextEvent (_,g,_) = readChan (_events g)++-- | 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++-- | Access the current state of the gateway cache+readCache :: (RestChan, Gateway, z) -> IO Cache+readCache (_,g,_) = readMVar (_cache g)++-- | Stop all the background threads+stopDiscord :: (x, y, [ThreadIdType]) -> IO ()+stopDiscord (_,_,is) = threadDelay (10^6 `div` 10) >> mapM_ (killThread . toId) is+ where toId t = case t of+ ThreadRest a -> a+ ThreadGateway a -> a+ ThreadLogger a -> a++-- | Add anything from the Chan to the log file, forever+logger :: Chan String -> Bool -> IO ()+logger log False = forever $ readChan log >>= \_ -> pure ()+logger log True = forever $ do+ x <- readChan log+ let line = x <> "\n\n"+ appendFile "the-log-of-discord-haskell.txt" line
+ src/Discord/Gateway.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_HADDOCK prune, not-home #-}++-- | Provides a rather raw interface to the websocket events+-- through a real-time Chan+module Discord.Gateway+ ( Gateway(..)+ , startGatewayThread+ , module Discord.Types+ ) where++import Prelude hiding (log)+import Control.Exception.Safe (finally)+import Control.Concurrent.Chan (newChan, dupChan, Chan)+import Control.Concurrent (forkIO, killThread, ThreadId, MVar)++import Discord.Types (Auth, Event, GatewaySendable)+import Discord.Gateway.EventLoop (connectionLoop)+import Discord.Gateway.Cache++-- | Concurrency primitives that make up the gateway. Build a higher+-- level interface over these+data Gateway = Gateway+ { _events :: Chan Event+ , _cache :: MVar 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+ writeFile "the-log-of-discord-haskell.txt" ""+ cache <- emptyCache+ cacheID <- forkIO $ addEvent cache eventsCache log+ tid <- forkIO $ finally (connectionLoop auth eventsWrite sends log)+ (killThread cacheID)+ pure (Gateway eventsWrite cache sends, tid)+++
+ src/Discord/Gateway/Cache.hs view
@@ -0,0 +1,70 @@+{-# 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.MVar+import Control.Concurrent.Chan+import qualified Data.Map.Strict as M++import Discord.Types++data Cache = Cache+ { _currentUser :: User+ , _dmChannels :: M.Map Snowflake Channel+ , _guilds :: M.Map Snowflake (Guild, GuildInfo)+ , _channels :: M.Map Snowflake Channel+ } deriving (Show)++emptyCache :: IO (MVar Cache)+emptyCache = newEmptyMVar++addEvent :: MVar Cache -> Chan Event -> Chan String -> IO ()+addEvent cache eventChan log = do+ ready <- readChan eventChan+ case ready of+ (Ready _ user dmChannels _unavailableGuilds _) -> do+ let dmChans = M.fromList (zip (map channelId dmChannels) dmChannels)+ putMVar cache (Cache user dmChans M.empty M.empty)+ loop+ _ -> do+ writeChan log ("Cache error - expected Ready, but got " <> show ready)+ addEvent cache eventChan log+ where+ loop :: IO ()+ loop = do+ event <- readChan eventChan+ minfo <- takeMVar cache+ putMVar cache (adjustCache minfo 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 :: Snowflake -> Channel -> Channel+setChanGuildID s c = if isGuildChannel c+ then c { channelGuild = s }+ else c
+ src/Discord/Gateway/EventLoop.hs view
@@ -0,0 +1,183 @@+{-# 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,+ sendClose, receiveData, sendTextData)++import Discord.Types++data ConnLoopState = ConnStart+ | ConnClosed+ | ConnReconnect T.Text String Integer+ deriving Show++data ConnectionData = ConnData { connection :: Connection+ , connSessionID :: String+ , connAuth :: T.Text+ , connChan :: Chan Event+ }++data Sendables = Sendables { userSends :: Chan GatewaySendable+ , gatewaySends :: Chan GatewaySendable+ }++sendableLoop :: Connection -> Sendables -> Chan [Char] -> IO ()+sendableLoop conn sends log = 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))+ writeChan log ("gateway - sending " <> QL.unpack (encode payload))+ sendTextData conn (encode payload)++-- | Securely run a connection IO action. Send a close on exception+connect :: Chan GatewaySendable -> Chan String+ -> (Connection -> Chan GatewaySendable -> IO a) -> IO a+connect sends log app = runSecureClient "gateway.discord.gg" 443 "/?v=6&encoding=json" $ \conn -> do+ gateSends <- newChan+ sendsId <- forkIO (sendableLoop conn (Sendables sends gateSends) log)+ finally (app conn gateSends)+ (sendClose conn ("" :: T.Text) >> killThread sendsId)++connectionLoop :: Auth -> Chan Event -> Chan GatewaySendable -> Chan String -> IO ()+connectionLoop auth events sends log = loop ConnStart+ where+ loop :: ConnLoopState -> IO ()+ loop s = do+ writeChan log ("conn loop: " <> show s)+ case s of+ (ConnClosed) -> writeChan log "Conn Closed"+ (ConnStart) -> do+ loop <=< connect sends log $ \conn send -> 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 r+ startEventStream conn events auth seshID interval 0 send log+ _ -> writeChan log ("received2: " <> show msg2) >> pure ConnClosed+ _ -> writeChan log ("received1: " <> show msg) >> pure ConnClosed++ (ConnReconnect tok seshID seqID) -> do+ next <- try $ connect sends log $ \conn send -> do+ sendTextData conn (encode (Resume tok seshID seqID))+ writeChan log "Resuming???"+ eitherPayload <- getPayload conn log+ case eitherPayload of+ Right (Hello interval) ->+ startEventStream conn events auth seshID interval seqID send log+ Right (InvalidSession retry) -> do+ t <- getRandomR (1,5)+ writeChan log ("Invalid sesh, sleep:" <> show t)+ threadDelay (t * 10^6)+ pure $ if retry+ then ConnReconnect tok seshID seqID+ else ConnStart+ Right payload -> do+ writeChan log ("Why did they send a: " <> show payload)+ pure ConnClosed+ Left e ->+ writeChan log ("message - error " <> show e) >> pure ConnClosed+ case next :: Either SomeException ConnLoopState of+ Left e -> do writeChan log ("exception - connecting: " <> show e)+ t <- getRandomR (3,10)+ threadDelay (t * 10^6)+ loop (ConnReconnect tok seshID seqID)+ Right n -> loop n+++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 (InvalidSession True))+ Right other -> pure other++getPayload :: Connection -> Chan String -> IO (Either ConnectionException GatewayReceivable)+getPayload conn log = try $ do+ msg' <- receiveData conn+ writeChan log ("message - received " <> QL.unpack msg')+ case eitherDecode msg' of+ Right msg -> return msg+ Left err -> do writeChan log ("parse error Error - " <> err)+ writeChan log ("parse error Message - " <> show msg')+ return (ParseError err)++heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> Chan String -> IO ()+heartbeat send interval seqKey log = do+ writeChan log "starting the heartbeat"+ forever $ do+ num <- readIORef seqKey+ writeChan send (Heartbeat num)+ threadDelay (interval * 1000)++setSequence :: IORef Integer -> Integer -> IO ()+setSequence key i = writeIORef key i++startEventStream :: Connection -> Chan Event -> Auth -> String -> Int+ -> Integer -> Chan GatewaySendable -> Chan String -> IO ConnLoopState+startEventStream conn events (Auth auth) seshID interval seqN send log = do+ seqKey <- newIORef seqN+ heart <- forkIO $ heartbeat send interval seqKey log++ let err :: SomeException -> IO ConnLoopState+ err e = do writeChan log ("error - " <> show e)+ ConnReconnect auth seshID <$> readIORef seqKey+ handle err $ finally (eventStream (ConnData conn seshID auth events) seqKey interval send log)+ (killThread heart)++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 documentation on gateway close event codes+ 1000 -> 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+ e -> do writeChan log ("Closing connection because #" <> show e <> " " <> show str)+ pure ConnClosed+ Left _ -> ConnReconnect auth seshID <$> readIORef seqKey+ Right (Dispatch event sq) -> do setSequence seqKey sq+ writeChan eventChan event+ loop+ Right (HeartbeatRequest sq) -> do setSequence seqKey sq+ writeChan send (Heartbeat sq)+ loop+ Right (Reconnect) -> do writeChan log "Should reconnect"+ ConnReconnect auth seshID <$> readIORef seqKey+ Right (InvalidSession retry) -> if retry+ then ConnReconnect auth seshID <$> readIORef seqKey+ else pure ConnStart+ Right (HeartbeatAck) -> loop+ Right p -> writeChan log ("error - Invalid gateway payload: " <> show p) >> pure ConnClosed
+ src/Discord/Rest.hs view
@@ -0,0 +1,47 @@+{-# 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+ ) where++import Prelude hiding (log)+import Data.Aeson (FromJSON, eitherDecode)+import Data.Monoid ((<>))+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 String 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 String 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 ("parse error - " <> er)+ Left err -> Left err+++
+ src/Discord/Rest/Channel.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides actions for Channel API interactions+module Discord.Rest.Channel+ ( ChannelRequest(..)+ , ReactionTiming(..)+ , MessageTiming(..)+ , ModifyChannelOptions(..)+ ) 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 :: Snowflake -> ChannelRequest Channel+ -- | Edits channels options.+ ModifyChannel :: Snowflake -> ModifyChannelOptions -> ChannelRequest Channel+ -- | Deletes a channel if its id doesn't equal to the id of guild.+ DeleteChannel :: Snowflake -> ChannelRequest Channel+ -- | Gets a messages from a channel with limit of 100 per request.+ GetChannelMessages :: Snowflake -> (Int, MessageTiming) -> ChannelRequest [Message]+ -- | Gets a message in a channel by its id.+ GetChannelMessage :: (Snowflake, Snowflake) -> ChannelRequest Message+ -- | Sends a message to a channel.+ CreateMessage :: Snowflake -> T.Text -> Maybe Embed -> ChannelRequest Message+ -- | Sends a message with a file to a channel.+ UploadFile :: Snowflake -> FilePath -> BL.ByteString -> ChannelRequest Message+ -- | Add an emoji reaction to a message. ID must be present for custom emoji+ CreateReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)+ -> ChannelRequest ()+ -- | Remove a Reaction this bot added+ DeleteOwnReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)+ -> ChannelRequest ()+ -- | Remove a Reaction someone else added+ DeleteUserReaction :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)+ -> Snowflake -> ChannelRequest ()+ -- | List of users that reacted with this emoji+ GetReactions :: (Snowflake, Snowflake) -> (T.Text, Maybe Snowflake)+ -> (Int, ReactionTiming) -> ChannelRequest ()+ -- | Delete all reactions on a message+ DeleteAllReactions :: (Snowflake, Snowflake) -> ChannelRequest ()+ -- | Edits a message content.+ EditMessage :: (Snowflake, Snowflake) -> T.Text -> Maybe Embed+ -> ChannelRequest Message+ -- | Deletes a message.+ DeleteMessage :: (Snowflake, Snowflake) -> ChannelRequest ()+ -- | Deletes a group of messages.+ BulkDeleteMessage :: (Snowflake, [Snowflake]) -> ChannelRequest ()+ -- todo | Edits a permission overrides for a channel.+ -- todo EditChannelPermissions :: ToJSON o => Snowflake -> Snowflake -> o -> ChannelRequest ()+ -- | Gets all instant invites to a channel.+ GetChannelInvites :: Snowflake -> ChannelRequest Object+ -- todo | Creates an instant invite to a channel.+ -- todo CreateChannelInvite :: ToJSON o => Snowflake -> o -> ChannelRequest Object+ -- | Deletes a permission override from a channel.+ DeleteChannelPermission :: Snowflake -> Snowflake -> ChannelRequest ()+ -- | Sends a typing indicator a channel which lasts 10 seconds.+ TriggerTypingIndicator :: Snowflake -> ChannelRequest ()+ -- | Gets all pinned messages of a channel.+ GetPinnedMessages :: Snowflake -> ChannelRequest [Message]+ -- | Pins a message.+ AddPinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest ()+ -- | Unpins a message.+ DeletePinnedMessage :: (Snowflake, Snowflake) -> ChannelRequest ()+ -- todo | Adds a recipient to a Group DM using their access token+ -- todo GroupDMAddRecipient :: Snowflake -> Snowflake -> ChannelRequest ()+ -- todo | Removes a recipient from a Group DM+ -- todo GroupDMRemoveRecipient :: Snowflake -> Snowflake -> ChannelRequest ()+++-- | Data constructor for GetReaction requests+data ReactionTiming = BeforeReaction Snowflake+ | AfterReaction Snowflake++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 Snowflake+ | BeforeMessage Snowflake+ | AfterMessage Snowflake++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++data ModifyChannelOptions = ModifyChannelOptions+ { modifyChannelName :: Maybe String+ , modifyChannelPosition :: Maybe Integer+ , modifyChannelTopic :: Maybe String+ , modifyChannelNSFW :: Maybe Bool+ , modifyChannelBitrate :: Maybe Integer+ , modifyChannelUserRateLimit :: Maybe Integer+ , modifyChannelPermissionOverwrites :: Maybe [Overwrite]+ , modifyChannelParentId :: Maybe Snowflake+ }++instance ToJSON ModifyChannelOptions where+ toJSON ModifyChannelOptions{..} = 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) ] ]++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+ (UploadFile chan _ _) -> "msg " <> show chan+ (CreateReaction (chan, _) _) -> "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+ -- todo (EditChannelPermissions chan _ _) -> "perms " <> show chan+ (GetChannelInvites chan) -> "invites " <> show chan+ -- todo (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+++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 embed) ->+ let content = ["content" .= msg] <> maybeEmbed embed+ body = pure $ R.ReqBodyJson $ object content+ in Post (channels // chan /: "messages") body mempty++ (UploadFile chan fileName file) ->+ let part = partFileRequestBody "file" fileName $ RequestBodyLBS file+ body = R.reqBodyMultipart [part]+ in Post (channels // chan /: "messages") body mempty++ (CreateReaction (chan, msgid) (name, rID)) ->+ let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID+ in Put (channels // chan /: "messages" // msgid /: "reactions" /: emoji /: "@me" )+ R.NoReqBody mempty++ (DeleteOwnReaction (chan, msgid) (name, rID)) ->+ let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID+ in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji /: "@me" ) mempty++ (DeleteUserReaction (chan, msgid) (name, rID) uID) ->+ let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID+ in Delete (channels // chan /: "messages" // msgid /: "reactions" /: emoji // uID ) mempty++ (GetReactions (chan, msgid) (name, rID) (n, timing)) ->+ let emoji = "" <> name <> maybe "" ((<>) ":" . T.pack . show) rID+ 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" /: emoji ) 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++ -- todo (EditChannelPermissions chan perm patch) ->+ -- Put (channels // chan /: "permissions" // perm) (R.ReqBodyJson patch) mempty++ (GetChannelInvites chan) ->+ Get (channels // chan /: "invites") mempty++ -- todo (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+
+ src/Discord/Rest/Emoji.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides actions for Channel API interactions+module Discord.Rest.Emoji+ ( EmojiRequest(..)+ , ModifyGuildEmojiOpts(..)+ ) 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 (EmojiRequest a) where+ majorRoute = userMajorRoute+ jsonRequest = userJsonRequest+++-- | 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 :: Snowflake -> EmojiRequest [Emoji]+ -- | Emoji object for the given guild and emoji ID+ GetGuildEmoji :: Snowflake -> Snowflake -> EmojiRequest Emoji+ -- | Create a new guild emoji. Requires MANAGE_EMOJIS permission.+ -- todo CreateGuildEmoji :: Snowflake -> T.Text -> Image128x128 -> EmojiRequest Emoji+ -- | Requires MANAGE_EMOJIS permission+ ModifyGuildEmoji :: Snowflake -> Snowflake -> ModifyGuildEmojiOpts -> EmojiRequest Emoji+ -- | Requires MANAGE_EMOJIS permission+ DeleteGuildEmoji :: Snowflake -> Snowflake -> EmojiRequest ()++data ModifyGuildEmojiOpts = ModifyGuildEmojiOpts+ { modifyGuildEmojiName :: T.Text+ , modifyGuildEmojiRoles :: [Snowflake]+ }++instance ToJSON ModifyGuildEmojiOpts where+ toJSON (ModifyGuildEmojiOpts name roles) =+ object [ "name" .= name, "roles" .= roles ]++userMajorRoute :: EmojiRequest a -> String+userMajorRoute c = case c of+ (ListGuildEmojis g) -> "emoji " <> show g+ (GetGuildEmoji g _) -> "emoji " <> show g+ -- todo (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"++userJsonRequest :: EmojiRequest r -> JsonRequest+userJsonRequest c = case c of+ (ListGuildEmojis g) -> Get (guilds // g) mempty+ (GetGuildEmoji g e) -> Get (guilds // g /: "emojis" // e) mempty+ -- todo (CreateGuildEmoji g) -> Post ()+ (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 view
@@ -0,0 +1,273 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides actions for Channel API interactions+module Discord.Rest.Guild+ ( GuildRequest(..)+ , GuildMembersTiming(..)+ ) where+++import Data.Aeson+import Data.Monoid (mempty, (<>))+import Network.HTTP.Req ((/:))+import qualified Network.HTTP.Req as R++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 :: Snowflake -> GuildRequest Guild+ -- | Modify a guild's settings. Returns the updated 'Guild' object on success. Fires a+ -- Guild Update 'Event'.+ -- todo ModifyGuild :: ToJSON o => Snowflake -> o -> GuildRequest Guild+ -- | Delete a guild permanently. User must be owner. Fires a Guild Delete 'Event'.+ DeleteGuild :: Snowflake -> GuildRequest Guild+ -- | Returns a list of guild 'Channel' objects+ GetGuildChannels :: Snowflake -> 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'+ -- todo CreateGuildChannel :: ToJSON o => Snowflake -> o -> 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.+ -- todo ModifyChanPosition :: ToJSON o => Snowflake -> o -> GuildRequest [Channel]+ -- | Returns a guild 'Member' object for the specified user+ GetGuildMember :: Snowflake -> Snowflake -> GuildRequest GuildMember+ -- | Returns a list of guild 'Member' objects that are members of the guild.+ ListGuildMembers :: Snowflake -> 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.+ -- todo AddGuildMember :: ToJSON o => Snowflake -> Snowflake -> o+ -- -> GuildRequest GuildMember+ -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'.+ -- todo ModifyGuildMember :: ToJSON o => Snowflake -> Snowflake -> o+ -- -> GuildRequest ()+ -- | Remove a member from a guild. Requires 'KICK_MEMBER' permission. Fires a+ -- Guild Member Remove 'Event'.+ RemoveGuildMember :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Returns a list of 'User' objects that are banned from this guild. Requires the+ -- 'BAN_MEMBERS' permission+ GetGuildBans :: Snowflake -> GuildRequest [User]+ -- | 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 :: Snowflake -> Snowflake -> Integer -> GuildRequest ()+ -- | Remove the ban for a user. Requires the 'BAN_MEMBERS' permissions.+ -- Fires a Guild Ban Remove 'Event'.+ RemoveGuildBan :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Returns a list of 'Role' objects for the guild. Requires the 'MANAGE_ROLES'+ -- permission+ GetGuildRoles :: Snowflake -> 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 :: Snowflake -> 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.+ -- todo ModifyGuildRolePositions :: ToJSON o => Snowflake -> [o] -> GuildRequest [Role]+ -- | Modify a guild role. Requires the 'MANAGE_ROLES' permission. Returns the+ -- updated 'Role' on success. Fires a Guild Role Update 'Event's.+ -- todo ModifyGuildRole :: ToJSON o => Snowflake -> Snowflake -> o+ -- -> GuildRequest Role+ -- | Delete a guild role. Requires the 'MANAGE_ROLES' permission. Fires a Guild Role+ -- Delete 'Event'.+ DeleteGuildRole :: Snowflake -> Snowflake -> 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 :: Snowflake -> 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 :: Snowflake -> 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 :: Snowflake -> GuildRequest [VoiceRegion]+ -- | Returns a list of 'Invite' objects for the guild. Requires the 'MANAGE_GUILD'+ -- permission.+ GetGuildInvites :: Snowflake -> GuildRequest [Invite]+ -- | Return a list of 'Integration' objects for the guild. Requires the 'MANAGE_GUILD'+ -- permission.+ GetGuildIntegrations :: Snowflake -> GuildRequest [Integration]+ -- | Attach an 'Integration' object from the current user to the guild. Requires the+ -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.+ -- todo CreateGuildIntegration :: ToJSON o => Snowflake -> o -> GuildRequest ()+ -- | Modify the behavior and settings of a 'Integration' object for the guild.+ -- Requires the 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.+ -- todo ModifyGuildIntegration :: ToJSON o => Snowflake -> Snowflake -> o -> GuildRequest ()+ -- | Delete the attached 'Integration' object for the guild. Requires the+ -- 'MANAGE_GUILD' permission. Fires a Guild Integrations Update 'Event'.+ DeleteGuildIntegration :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Sync an 'Integration'. Requires the 'MANAGE_GUILD' permission.+ SyncGuildIntegration :: Snowflake -> Snowflake -> GuildRequest ()+ -- | Returns the 'GuildEmbed' object. Requires the 'MANAGE_GUILD' permission.+ GetGuildEmbed :: Snowflake -> 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 :: Snowflake -> GuildEmbed -> GuildRequest GuildEmbed++data GuildMembersTiming = GuildMembersTiming+ { _guildMembersTimingLimit :: Maybe Int+ , _guildMembersTimingAfter :: Maybe Snowflake+ }++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+ -- (ModifyChanPosition g _) -> "guild_chan " <> show g+ (GetGuildMember g _) -> "guild_memb " <> show g+ (ListGuildMembers g _) -> "guild_membs " <> show g+ -- (AddGuildMember g _ _) -> "guild_memb " <> show g+ -- (ModifyGuildMember g _ _) -> "guild_memb " <> show g+ (RemoveGuildMember g _) -> "guild_memb " <> 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+++-- | 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 patch) ->+ -- Post (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty++ -- (ModifyChanPosition guild patch) ->+ -- Post (guilds // guild /: "channels") (pure (R.ReqBodyJson patch)) mempty++ (GetGuildMember guild member) ->+ Get (guilds // guild /: "members" // member) mempty++ (ListGuildMembers guild range) ->+ Get (guilds // guild /: "members") (guildMembersTimingToQuery range)++ -- (AddGuildMember guild user patch) ->+ -- Put (guilds // guild /: "members" // user) (R.ReqBodyJson patch) mempty++ -- (ModifyGuildMember guild member patch) ->+ -- let body = R.ReqBodyJson patch+ -- in Patch (guilds // guild /: "members" // member) body mempty++ (RemoveGuildMember guild user) ->+ Delete (guilds // guild /: "members" // user) mempty++ (GetGuildBans guild) ->+ Get (guilds // guild /: "bans") mempty++ (CreateGuildBan guild user msgs) ->+ let body = R.ReqBodyJson (object ["delete-message-days" .= msgs])+ in Put (guilds // guild /: "bans" // user) body mempty++ (RemoveGuildBan guild ban) ->+ Delete (guilds // guild /: "bans" // ban) mempty++ (GetGuildRoles guild) ->+ Get (guilds // guild /: "roles") mempty++ (CreateGuildRole guild) ->+ Post (guilds // guild /: "roles") (pure R.NoReqBody) mempty++ -- (ModifyGuildRolePositions guild patch) ->+ -- Post (guilds // guild /: "roles") (pure (R.ReqBodyJson patch)) 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 patch) ->+ -- Post (guilds // guild /: "integrations") (pure (R.ReqBodyJson patch)) mempty++ -- (ModifyGuildIntegration guild integ patch) ->+ -- let body = R.ReqBodyJson patch+ -- in Patch (guilds // guild /: "integrations" // integ) 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+
+ src/Discord/Rest/HTTP.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiWayIf #-}++-- | Provide HTTP primitives+module Discord.Rest.HTTP+ ( restLoop+ , Request(..)+ , JsonRequest(..)+ ) where++import Prelude hiding (log)+import Data.Semigroup ((<>))++import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Data.Ix (inRange)+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++unpackResp :: Either String QL.ByteString -> String+unpackResp r = case r of+ Right a -> "Resp " <> QL.unpack a+ Left s -> "BadResp " <> s++restLoop :: Auth -> Chan (String, JsonRequest, MVar (Either String 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+ (resp, retry) <- restIOtoIO (tryRequest action log)+ writeChan log ("rest - got response " <> unpackResp resp)+ case resp of+ Right "" -> putMVar thread (Right "[]") -- empty should be ()+ Right bs -> putMVar thread (Right bs)+ Left "Try Again" -> writeChan urls (route, request, thread)+ Left r -> putMVar thread (Left r)+ case retry of+ GlobalWait i -> do+ writeChan log ("rest - GLOBAL WAIT " <> show ((i - curtime) * 1000))+ threadDelay $ round ((i - curtime + 0.1) * 1000)+ loop ratelocker+ PathWait i -> loop $ M.insert route i ratelocker+ NoLimit -> loop ratelocker++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 RateLimited = Available | Locked++data Timeout = GlobalWait POSIXTime+ | PathWait POSIXTime+ | NoLimit+++tryRequest :: RestIO R.LbsResponse -> Chan String -> RestIO (Either String QL.ByteString, Timeout)+tryRequest action log = do+ resp <- action+ next10 <- liftIO (round . (+10) <$> getPOSIXTime)+ let 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 (Left "Try Again", if global then GlobalWait reset+ else PathWait reset)+ | code `elem` [500,502] -> pure (Left "Try Again", NoLimit)+ | inRange (200,299) code -> pure ( Right (R.responseBody resp)+ , if remain > 0 then NoLimit else PathWait reset )+ | inRange (400,499) code -> pure ( Left (show code <> " - " <> Q.unpack status+ <> QL.unpack (R.responseBody resp))+ , if remain > 0 then NoLimit else PathWait reset )+ | otherwise -> let err = "Unexpected code: " ++ show code ++ " - " ++ Q.unpack status+ in pure (Left err, 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/Prelude.hs view
@@ -0,0 +1,55 @@+{-# 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.5.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/Rest/User.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides actions for Channel API interactions+module Discord.Rest.User+ ( UserRequest(..)+ ) where+++import Data.Aeson+import Data.Monoid (mempty, (<>))+import Network.HTTP.Req ((/:))+import qualified Network.HTTP.Req as R++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 :: Snowflake -> UserRequest User+ -- | Modify the requestors user account settings. Returns a 'User' object on success.+ -- todo ModifyCurrentUser :: ToJSON o => o -> 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 :: Snowflake -> 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 :: Snowflake -> UserRequest Channel+++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 "++-- | 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 patch) ->+ -- Patch (users /: "@me") (R.ReqBodyJson patch) 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
+ src/Discord/Types.hs view
@@ -0,0 +1,20 @@+{-# 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+ ) 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)
+ src/Discord/Types/Channel.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Data structures pertaining to Discord Channels+module Discord.Types.Channel where++import qualified Data.Text as T++import Data.Aeson+import Data.Aeson.Types (Parser)+import Data.Time.Clock+import Data.Monoid ((<>))+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 :: Snowflake -- ^ The user's id.+ , userName :: String -- ^ The user's username, not unique across+ -- the platform.+ , userDiscrim :: String -- ^ The user's 4-digit discord-tag.+ , userAvatar :: Maybe String -- ^ The user's avatar hash.+ , userIsBot :: Bool -- ^ Whether the user belongs to an OAuth2+ -- application.+ , userMfa :: Maybe Bool -- ^ Whether the user has two factor+ -- authentication enabled on the account.+ , userVerified :: Maybe Bool -- ^ Whether the email on this account has+ -- been verified.+ , userEmail :: Maybe String -- ^ The user's email.+ }+ | Webhook deriving (Show, Eq)++instance FromJSON User where+ parseJSON = withObject "Useer" $ \o ->+ User <$> o .: "id"+ <*> o .: "username"+ <*> o .: "discriminator"+ <*> o .:? "avatar"+ <*> o .:? "bot" .!= False+ <*> o .:? "mfa_enabled"+ <*> o .:? "verified"+ <*> o .:? "email"++-- | Guild channels represent an isolated set of users and messages in a Guild (Server)+data Channel+ -- | A text channel in a guild.+ = Text+ { channelId :: Snowflake -- ^ The id of the channel (Will be equal to+ -- the guild if it's the "general" channel).+ , channelGuild :: Snowflake -- ^ 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 Snowflake -- ^ The id of the last message sent in the+ -- channel+ }+ -- | A voice channel in a guild.+ | Voice+ { channelId :: Snowflake+ , channelGuild :: Snowflake+ , 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+ | DirectMessage+ { channelId :: Snowflake+ , channelRecipients :: [User] -- ^ The 'User' object(s) of the DM recipient(s).+ , channelLastMessage :: Maybe Snowflake+ }+ | GroupDM+ { channelId :: Snowflake+ , channelRecipients :: [User]+ , channelLastMessage :: Maybe Snowflake+ }+ | GuildCategory+ { channelId :: Snowflake+ , channelGuild :: Snowflake+ } deriving (Show, Eq)++instance FromJSON Channel where+ parseJSON = withObject "Channel" $ \o -> do+ type' <- (o .: "type") :: Parser Int+ case type' of+ 0 ->+ Text <$> o .: "id"+ <*> o .:? "guild_id" .!= 0+ <*> o .: "name"+ <*> o .: "position"+ <*> o .: "permission_overwrites"+ <*> o .:? "topic" .!= ""+ <*> o .:? "last_message_id"+ 1 ->+ DirectMessage <$> o .: "id"+ <*> o .: "recipients"+ <*> o .:? "last_message_id"+ 2 ->+ Voice <$> o .: "id"+ <*> o .:? "guild_id" .!= 0+ <*> o .: "name"+ <*> o .: "position"+ <*> o .: "permission_overwrites"+ <*> o .: "bitrate"+ <*> o .: "user_limit"+ 3 ->+ GroupDM <$> o .: "id"+ <*> o .: "recipients"+ <*> o .:? "last_message_id"+ 4 ->+ GuildCategory <$> 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)+isGuildChannel :: Channel -> Bool+isGuildChannel c = case c of+ GuildCategory{..} -> True+ Text{..} -> True+ Voice{..} -> True+ _ -> False++-- | Permission overwrites for a channel.+data Overwrite = Overwrite+ { overwriteId :: Snowflake -- ^ '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)++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 :: Snowflake -- ^ The id of the message+ , messageChannel :: Snowflake -- ^ Id of the channel the message+ -- was sent in+ , messageAuthor :: User -- ^ The 'User' the message was sent+ -- by+ , messageText :: T.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 :: [Snowflake] -- ^ '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+ } deriving (Show, Eq)++instance FromJSON Message where+ parseJSON = withObject "Message" $ \o ->+ Message <$> o .: "id"+ <*> o .: "channel_id"+ <*> o .:? "author" .!= Webhook+ <*> 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++-- | 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)++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 :: String -- ^ Title of the embed+ , embedType :: String -- ^ Type of embed (Always "rich" for webhooks)+ , embedDesc :: String -- ^ Description of embed+ , embedUrl :: String -- ^ URL of embed+ , embedTime :: UTCTime -- ^ The time of the embed content+ , embedColor :: Integer -- ^ The embed color+ , embedFields :: [SubEmbed] -- ^ Fields of the embed+ } deriving (Show, Read, Eq)++instance FromJSON Embed where+ parseJSON = withObject "Embed" $ \o ->+ Embed <$> o .:? "title" .!= "Untitled"+ <*> o .: "type"+ <*> o .:? "description" .!= ""+ <*> o .:? "url" .!= ""+ <*> o .:? "timestamp" .!= epochTime+ <*> o .:? "color" .!= 0+ <*> 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" .= embedDesc+ , "url" .= embedUrl+ , "timestamp" .= embedTime+ , "color" .= embedColor+ ] |> makeSubEmbeds embedFields+ where+ (|>) :: Value -> HM.HashMap T.Text Value -> Value+ (|>) (Object o) hm = Object $ HM.union o hm+ (|>) _ _ = error "Type mismatch"++ makeSubEmbeds :: [SubEmbed] -> HM.HashMap T.Text Value+ makeSubEmbeds = foldr embed HM.empty++ embed :: SubEmbed -> HM.HashMap T.Text Value -> HM.HashMap T.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, Read, Eq)
+ src/Discord/Types/Events.hs view
@@ -0,0 +1,156 @@+{-# 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 (Snowflake)+import Discord.Types.Channel+import Discord.Types.Guild (Guild, Unavailable, 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] [Unavailable] String+ | Resumed [T.Text]+ | ChannelCreate Channel+ | ChannelUpdate Channel+ | ChannelDelete Channel+ | ChannelPinsUpdate Snowflake (Maybe UTCTime)+ | GuildCreate Guild GuildInfo+ | GuildUpdate Guild+ | GuildDelete Unavailable+ | GuildBanAdd Snowflake User+ | GuildBanRemove Snowflake User+ | GuildEmojiUpdate Snowflake [Emoji]+ | GuildIntegrationsUpdate Snowflake+ | GuildMemberAdd Snowflake GuildMember+ | GuildMemberRemove Snowflake User+ | GuildMemberUpdate Snowflake [Snowflake] User String+ | GuildMemberChunk Snowflake [GuildMember]+ | GuildRoleCreate Snowflake Role+ | GuildRoleUpdate Snowflake Role+ | GuildRoleDelete Snowflake Snowflake+ | MessageCreate Message+ | MessageUpdate Message+ | MessageDelete Snowflake Snowflake+ | MessageDeleteBulk Snowflake [Snowflake]+ | MessageReactionAdd ReactionInfo+ | MessageReactionRemove ReactionInfo+ | MessageReactionRemoveAll Snowflake Snowflake+ | PresenceUpdate PresenceInfo+ | TypingStart TypingInfo+ | UserUpdate User+ -- | VoiceStateUpdate+ -- | VoiceServerUpdate+ | UnknownEvent String Object+ deriving Show++data ReactionInfo = ReactionInfo+ { reactionUserId :: Snowflake+ , reactionChannelId :: Snowflake+ , reactionMessageId :: Snowflake+ , reactionEmoji :: Emoji+ } deriving Show++instance FromJSON ReactionInfo where+ parseJSON = withObject "ReactionInfo" $ \o ->+ ReactionInfo <$> o .: "user_id"+ <*> o .: "channel_id"+ <*> o .: "message_id"+ <*> o .: "emoji"++data PresenceInfo = PresenceInfo+ { presenceUserId :: Snowflake+ , presenceRoles :: [Snowflake]+ -- , presenceGame :: Maybe Activity+ , presenceGuildId :: Snowflake+ , presenceStatus :: String+ } deriving Show++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 :: Snowflake+ , typingChannelId :: Snowflake+ , typingTimestamp :: UTCTime+ } deriving Show++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" <*> reparse o+ "GUILD_BAN_REMOVE" -> GuildBanRemove <$> o .: "guild_id" <*> reparse o+ "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"+ "MESSAGE_CREATE" -> MessageCreate <$> reparse o+ "MESSAGE_UPDATE" -> MessageUpdate <$> reparse o+ "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 view
@@ -0,0 +1,161 @@+{-# 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++data GatewaySendable+ = Heartbeat Integer+ | Identify Auth Bool Integer (Int, Int)+ | Resume T.Text String Integer+ | RequestGuildMembers RequestGuildMembersOpts+ | UpdateStatus UpdateStatusOpts+ | UpdateStatusVoice UpdateStatusVoiceOpts++data RequestGuildMembersOpts = RequestGuildMembersOpts+ { requestGuildMemersGuildId :: Snowflake+ , requestGuildMemersSearchQuery :: T.Text+ , requestGuildMemersLimit :: Integer }++data UpdateStatusVoiceOpts = UpdateStatusVoiceOpts+ { updateStatusVoiceGuildId :: Snowflake+ , updateStatusVoiceChannelId :: Maybe Snowflake+ , updateStatusVoiceIsMuted :: Snowflake+ , updateStatusVoiceIsDeaf :: Snowflake+ }++data UpdateStatusOpts = UpdateStatusOpts+ { updateStatusSince :: Maybe UTCTime+ -- todo , updateStatusGame :: Activity+ , updateStatusNewStatus :: UpdateStatusTypes+ , updateStatusAFK :: Bool+ }++data UpdateStatusTypes = UpdateStatusOnline+ | UpdateStatusDoNotDisturb+ | UpdateStatusAwayFromKeyboard+ | UpdateStatusInvisibleOffline+ | UpdateStatusOffline++statusString :: UpdateStatusTypes -> 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 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" .= (Nothing :: Maybe ())+ -- todo , "game" .= object [+ -- "name" .= game+ -- ]+ ]+ ]+ 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 view
@@ -0,0 +1,288 @@+{-# 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++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 :: !Snowflake -- ^ Gulid id+ , guildName :: T.Text -- ^ Guild name (2 - 100 chars)+ , guildIcon :: Maybe T.Text -- ^ Icon hash+ , guildSplash :: Maybe T.Text -- ^ Splash hash+ , guildOwnerId :: !Snowflake -- ^ Guild owner id+ , guildPermissions :: Maybe Integer+ , guildRegion :: T.Text -- ^ Guild voice region+ , guildAfkId :: Maybe Snowflake -- ^ Id of afk channel+ , guildAfkTimeout :: !Integer -- ^ Afk timeout in seconds+ , guildEmbedEnabled :: Maybe Bool -- ^ Id of embedded channel+ , guildEmbedChannel :: Maybe Snowflake -- ^ 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++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 Unavailable = Unavailable+ { idOnceAvailable :: !Snowflake+ } deriving Show++instance FromJSON Unavailable where+ parseJSON = withObject "Unavailable" $ \o ->+ Unavailable <$> 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++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 :: Snowflake+ , partialGuildName :: T.Text+ , partialGuildIcon :: Maybe T.Text+ , partialGuildOwner :: Bool+ , partialGuildPermissions :: Integer+ } deriving Show++instance FromJSON PartialGuild where+ parseJSON = withObject "PartialGuild" $ \o ->+ PartialGuild <$> o .: "id"+ <*> o .: "name"+ <*> o .:? "icon"+ <*> o .: "owner"+ <*> o .: "permissions"++-- | Represents an emoticon (emoji)+data Emoji = Emoji+ { emojiId :: Maybe Snowflake -- ^ The emoji id+ , emojiName :: T.Text -- ^ The emoji name+ , emojiRoles :: Maybe [Snowflake] -- ^ Roles the emoji is active for+ , emojiManaged :: Maybe Bool -- ^ Whether this emoji is managed+ } deriving (Show)++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 :: !Snowflake -- ^ 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)++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+ { regionId :: !Snowflake -- ^ Unique id of the region+ , regionName :: T.Text -- ^ Name of the region+ , regionHostname :: T.Text -- ^ Example hostname for the region+ , regionPort :: Int -- ^ Example port for the region+ , regionVip :: Bool -- ^ True if this is a VIP only server+ , regionOptimal :: Bool -- ^ True for the closest server to a client+ , regionDepreciated :: Bool -- ^ Whether this is a deprecated region+ , regionCustom :: Bool -- ^ Whether this is a custom region+ } deriving (Show)++instance FromJSON VoiceRegion where+ parseJSON = withObject "VoiceRegion" $ \o ->+ VoiceRegion <$> o .: "id"+ <*> o .: "name"+ <*> o .: "sample_hostname"+ <*> o .: "sample_port"+ <*> o .: "vip"+ <*> o .: "optimal"+ <*> o .: "deprecated"+ <*> o .: "custom"++-- | Represents a code to add a user to a guild+data Invite = Invite+ { inviteCode :: T.Text -- ^ The invite code+ , inviteGuild :: !Snowflake -- ^ The guild the code will invite to+ , inviteChan :: !Snowflake -- ^ The channel the code will invite to+ }++instance FromJSON Invite where+ parseJSON = withObject "Invite" $ \o ->+ Invite <$> o .: "code"+ <*> ((o .: "guild") >>= (.: "id"))+ <*> ((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+ }++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 :: Snowflake -- ^ 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)++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 =+ Account+ { accountId :: T.Text -- ^ The id of the account.+ , accountName :: T.Text -- ^ The name of the account.+ } deriving (Show)++instance FromJSON IntegrationAccount where+ parseJSON = withObject "Account" $ \o ->+ Account <$> 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 :: !Snowflake -- ^ The embed channel id+ }++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 view
@@ -0,0 +1,54 @@+{-# 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 token) = "Bot " <> TE.encodeUtf8 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++-- | Gets a creation date from a snowflake.+creationDate :: Snowflake -> UTCTime+creationDate x = posixSecondsToUTCTime . realToFrac+ $ 1420070400 + quot (shiftR x 22) 1000++-- | Default timestamp+epochTime :: UTCTime+epochTime = posixSecondsToUTCTime 0+