discord-hs (empty) → 0.1.3
raw patch · 18 files changed
+2084/−0 lines, 18 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, case-insensitive, containers, data-default, hakyll, hashable, hslogger, lens, mmorph, mtl, pipes, split, stm, stm-conduit, text, time, transformers, unordered-containers, url, vector, websockets, wreq, wuss
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- discord-hs.cabal +74/−0
- docs/Site.hs +33/−0
- src/Network/Discord.hs +17/−0
- src/Network/Discord/Framework.hs +175/−0
- src/Network/Discord/Gateway.hs +96/−0
- src/Network/Discord/Rest.hs +58/−0
- src/Network/Discord/Rest/Channel.hs +191/−0
- src/Network/Discord/Rest/Guild.hs +295/−0
- src/Network/Discord/Rest/Prelude.hs +92/−0
- src/Network/Discord/Rest/User.hs +102/−0
- src/Network/Discord/Types.hs +79/−0
- src/Network/Discord/Types/Channel.hs +328/−0
- src/Network/Discord/Types/Events.hs +92/−0
- src/Network/Discord/Types/Gateway.hs +120/−0
- src/Network/Discord/Types/Guild.hs +238/−0
- src/Network/Discord/Types/Prelude.hs +72/−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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ discord-hs.cabal view
@@ -0,0 +1,74 @@+name: discord-hs+version: 0.1.3+synopsis: An API wrapper for Discord in Haskell+description: Provides an api wrapper and framework for writing+ bots against the Discord <https://discordapp.com/> API. + If for some reason hackage/stackage is failing to build+ documentation, a backup set is hosted at <https://jano017.github.io/Discord.hs/>+homepage: https://github.com/jano017/Discord.hs+license: MIT+license-file: LICENSE+author: Joshua Koike+maintainer: jkoike2013@gmail.com+-- copyright:+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Network.Discord+ , Network.Discord.Framework+ , Network.Discord.Gateway+ , Network.Discord.Rest+ , Network.Discord.Rest.Channel+ , Network.Discord.Rest.Guild+ , Network.Discord.Rest.User+ , Network.Discord.Types+ , Network.Discord.Types.Channel+ , Network.Discord.Types.Events+ , Network.Discord.Types.Gateway+ , Network.Discord.Types.Guild+ other-modules: Paths_discord_hs+ , Network.Discord.Rest.Prelude+ , Network.Discord.Types.Prelude+ -- other-extensions:+ build-depends: base==4.*+ , aeson==1.0.*+ , bytestring==0.10.*+ , case-insensitive==1.2.*+ , containers==0.5.*+ , data-default==0.7.*+ , hashable==1.2.*+ , hslogger==1.2.*+ , lens==4.15.*+ , mmorph==1.0.*+ , mtl==2.2.*+ , pipes==4.3.*+ , stm-conduit==3.0.*+ , stm==2.4.*+ , text==1.2.*+ , time==1.6.*+ , transformers==0.5.*+ , unordered-containers==0.2.*+ , url==2.1.*+ , vector==0.11.*+ , websockets==0.10.*+ , wreq==0.5.*+ , wuss==1.1.*+ ghc-options: -Wall+ hs-source-dirs: src+ default-language: Haskell2010+ +executable docs+ main-is: Site.hs+ hs-source-dirs: docs+ build-depends: base==4.*+ , hakyll+ , split+ ghc-options: -Wall+ default-language: Haskell2010++source-repository head+ type : git+ location: https://github.com/jano017/Discord.hs
+ docs/Site.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++import Hakyll+import Data.List+import Data.List.Split++config :: Configuration+config = defaultConfiguration { providerDirectory = "docs/build" }++hackage :: String -> String+hackage xs = fixUrl $ splitWhen (=='/') xs+ where+ fixUrl ("..":package:ys) = "https://hackage.haskell.org/package/" ++ package ++ "/docs/" ++ intercalate "/" ys+ fixUrl zs = intercalate "/" zs++main :: IO ()+main = do+ hakyllWith config $ do+ match "Network-*.html" $ do+ route idRoute+ compile $ fmap (withUrls hackage) <$> (relativizeUrls =<< getResourceString)++ match "index.html" $ do+ route idRoute+ compile $ relativizeUrls =<< getResourceString++ match "*.css" $ do+ route idRoute+ compile $ relativizeUrls =<< getResourceString++ match "*.js" $ do+ route idRoute+ compile $ relativizeUrls =<< getResourceString
+ src/Network/Discord.hs view
@@ -0,0 +1,17 @@+-- | Provides core Discord functionallity. +module Network.Discord+ ( module Network.Discord.Framework+ , module Network.Discord.Rest+ , module Network.Discord.Types+ , module Network.Discord.Gateway+ , module Control.Monad.State+ , module Pipes+ , module Pipes.Core+ ) where+ import Network.Discord.Framework+ import Network.Discord.Rest+ import Network.Discord.Types+ import Network.Discord.Gateway+ import Pipes ((~>), (>->), yield, await)+ import Pipes.Core ((+>>))+ import Control.Monad.State (get, put, liftIO, void, when, unless)
+ src/Network/Discord/Framework.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeFamilies, ExistentialQuantification, RankNTypes, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Provides a convenience framework for writing Discord bots without dealing with Pipes+module Network.Discord.Framework where+ import Control.Concurrent+ import Control.Monad.Writer+ import Data.Proxy++ import Control.Concurrent.STM+ import Control.Monad.State (execStateT, get)+ import Data.Aeson (Object)+ import Pipes ((~>))+ import Pipes.Core hiding (Proxy)+ import System.Log.Logger++ import Network.Discord.Gateway as D+ import Network.Discord.Rest as D+ import Network.Discord.Types as D++ -- | Isolated state representation for use with async event handling+ asyncState :: D.Client a => a -> Effect DiscordM DiscordState+ asyncState client = do+ DiscordState { getRateLimits = limits } <- get+ return $ DiscordState+ Running+ client+ undefined+ undefined+ limits+ + -- | Basic client implementation. Most likely suitable for most bots.+ data BotClient = BotClient Auth+ instance D.Client BotClient where+ getAuth (BotClient auth) = auth++ -- | This should be the entrypoint for most Discord bots.+ runBot :: Auth -> DiscordBot BotClient () -> IO ()+ runBot auth bot = runBotWith (BotClient auth) bot++ -- | A variant of 'runBot' which allows the user to specify a custom client implementation.+ runBotWith :: D.Client a => a -> DiscordBot a () -> IO ()+ runBotWith client bot = do+ gateway <- getGateway+ atomically $ writeTVar getTMClient client+ runWebsocket gateway client $ do+ DiscordState {getWebSocket=ws} <- get+ (eventCore ~> (handle $ execWriter bot)) ws++ -- | Utility function to split event handlers into a seperate thread+ runAsync :: D.Client client => Proxy client -> Effect DiscordM () -> Effect DiscordM ()+ runAsync c effect = do+ client <- liftIO . atomically $ getSTMClient c+ st <- asyncState client+ liftIO . void $ forkFinally + (execStateT (runEffect effect) st)+ finish+ where+ finish (Right DiscordState{getClient = st}) = atomically $ mergeClient st+ finish (Left err) = errorM "Language.Discord.Events" $ show err++ -- | Monad to compose event handlers+ type DiscordBot c a = Writer (Handle c) a++ -- | Event handlers for 'Gateway' events. These correspond to events listed in+ -- 'Event'+ data D.Client c => Handle c = Null + | Misc (Event -> Effect DiscordM ())+ | ReadyEvent (Init -> Effect DiscordM ())+ | ResumedEvent (Object -> Effect DiscordM ())+ | ChannelCreateEvent (Channel -> Effect DiscordM ())+ | ChannelUpdateEvent (Channel -> Effect DiscordM ())+ | ChannelDeleteEvent (Channel -> Effect DiscordM ())+ | GuildCreateEvent (Guild -> Effect DiscordM ())+ | GuildUpdateEvent (Guild -> Effect DiscordM ())+ | GuildDeleteEvent (Guild -> Effect DiscordM ())+ | GuildBanAddEvent (Member -> Effect DiscordM ())+ | GuildBanRemoveEvent (Member -> Effect DiscordM ())+ | GuildEmojiUpdateEvent (Object -> Effect DiscordM ())+ | GuildIntegrationsUpdateEvent (Object -> Effect DiscordM ())+ | GuildMemberAddEvent (Member -> Effect DiscordM ())+ | GuildMemberRemoveEvent (Member -> Effect DiscordM ())+ | GuildMemberUpdateEvent (Member -> Effect DiscordM ())+ | GuildMemberChunkEvent (Object -> Effect DiscordM ())+ | GuildRoleCreateEvent (Object -> Effect DiscordM ())+ | GuildRoleUpdateEvent (Object -> Effect DiscordM ())+ | GuildRoleDeleteEvent (Object -> Effect DiscordM ())+ | MessageCreateEvent (Message -> Effect DiscordM ())+ | MessageUpdateEvent (Message -> Effect DiscordM ())+ | MessageDeleteEvent (Object -> Effect DiscordM ())+ | MessageDeleteBulkEvent (Object -> Effect DiscordM ())+ | PresenceUpdateEvent (Object -> Effect DiscordM ())+ | TypingStartEvent (Object -> Effect DiscordM ())+ | UserSettingsUpdateEvent (Object -> Effect DiscordM ())+ | UserUpdateEvent (Object -> Effect DiscordM ())+ | VoiceStateUpdateEvent (Object -> Effect DiscordM ())+ | VoiceServerUpdateEvent (Object -> Effect DiscordM ())+ | Event String (Object -> Effect DiscordM ())++ -- | Provides a typehint for the correct 'D.Client' given an Event 'Handle'+ clientProxy :: Handle c -> Proxy c+ clientProxy _ = Proxy++ -- | Register an Event 'Handle' in the 'DiscordBot' monad+ with :: D.Client c => (a -> Handle c) -> a -> DiscordBot c ()+ with f a = tell $ f a+ + instance D.Client c => Monoid (Handle c) where+ mempty = Null+ a `mappend` b = Misc (\ev -> handle a ev <> handle b ev)++ -- | Asynchronously run an Event 'Handle' against a Gateway 'Event'+ handle :: D.Client a => Handle a -> Event -> Effect DiscordM ()+ handle a@(Misc p) ev + = runAsync (clientProxy a) $ p ev+ handle a@(ReadyEvent p) (D.Ready o) + = runAsync (clientProxy a) $ p o+ handle a@(ResumedEvent p) (D.Resumed o) + = runAsync (clientProxy a) $ p o+ handle a@(ChannelCreateEvent p) (D.ChannelCreate o) + = runAsync (clientProxy a) $ p o+ handle a@(ChannelUpdateEvent p) (D.ChannelUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(ChannelDeleteEvent p) (D.ChannelDelete o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildCreateEvent p) (D.GuildCreate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildUpdateEvent p) (D.GuildUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildDeleteEvent p) (D.GuildDelete o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildBanAddEvent p) (D.GuildBanAdd o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildBanRemoveEvent p) (D.GuildBanRemove o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildEmojiUpdateEvent p) (D.GuildEmojiUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildIntegrationsUpdateEvent p) (D.GuildIntegrationsUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildMemberAddEvent p) (D.GuildMemberAdd o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildMemberRemoveEvent p) (D.GuildMemberRemove o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildMemberUpdateEvent p) (D.GuildMemberUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildMemberChunkEvent p) (D.GuildMemberChunk o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildRoleCreateEvent p) (D.GuildRoleCreate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildRoleUpdateEvent p) (D.GuildRoleUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(GuildRoleDeleteEvent p) (D.GuildRoleDelete o) + = runAsync (clientProxy a) $ p o+ handle a@(MessageCreateEvent p) (D.MessageCreate o) + = runAsync (clientProxy a) $ p o+ handle a@(MessageUpdateEvent p) (D.MessageUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(MessageDeleteEvent p) (D.MessageDelete o) + = runAsync (clientProxy a) $ p o+ handle a@(MessageDeleteBulkEvent p) (D.MessageDeleteBulk o) + = runAsync (clientProxy a) $ p o+ handle a@(PresenceUpdateEvent p) (D.PresenceUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(TypingStartEvent p) (D.TypingStart o) + = runAsync (clientProxy a) $ p o+ handle a@(UserSettingsUpdateEvent p) (D.UserSettingsUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(UserUpdateEvent p) (D.UserUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(VoiceStateUpdateEvent p) (D.VoiceStateUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(VoiceServerUpdateEvent p) (D.VoiceServerUpdate o) + = runAsync (clientProxy a) $ p o+ handle a@(Event s p) (D.UnknownEvent v o)+ | s == v = runAsync (clientProxy a) $ p o+ handle _ ev = liftIO $ debugM "Discord-hs.Language.Events" $ show ev
+ src/Network/Discord/Gateway.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, RankNTypes #-}+{-# OPTIONS_HADDOCK prune, not-home #-}+-- | Provides logic code for interacting with the Discord websocket+-- gateway. Reallistically, this is probably lower level than most+-- people will need, and you should use Language.Discord.+module Network.Discord.Gateway where+ import Control.Concurrent (forkIO, threadDelay)+ import Control.Monad.State+ import Data.ByteString.Lazy.Char8 (unpack)++ import Control.Concurrent.STM+ import Data.Aeson+ import Data.Aeson.Types+ import Network.WebSockets+ import Network.URL+ import Pipes+ import System.Log.Logger+ import Wuss++ import Network.Discord.Types++ -- | Turn a websocket Connection into a Pipes Producer+ -- (data source)+ makeWebsocketSource :: (FromJSON a, MonadIO m)+ => Connection -> Producer a m ()+ makeWebsocketSource conn = forever $ do+ msg' <- lift . liftIO $ receiveData conn+ case eitherDecode msg' of+ Right msg -> yield $ msg+ Left err -> liftIO $+ errorM "Discord-hs.Gateway.Parse" err+ >> infoM "Discord-hs.Gateway.Raw" (unpack msg')++ -- | Starts a websocket connection that allows you to handle Discord events.+ runWebsocket :: (Client c)+ => URL -> c -> Effect DiscordM a -> IO a+ runWebsocket (URL (Absolute h) path _) client inner = do+ rl <- newTVarIO []+ runSecureClient (host h) 443 (path++"/?v=6")+ $ \conn -> evalStateT (runEffect inner)+ (DiscordState Create client conn undefined rl)+ runWebsocket _ _ _ = mzero++ -- | Spawn a heartbeat thread+ heartbeat :: Int -> Connection -> TMVar Integer -> IO ()+ heartbeat interval conn sq = void . forkIO . forever $ do+ seqNum <- atomically $ readTMVar sq+ sendTextData conn $ Heartbeat seqNum+ threadDelay $ interval * 1000+ + -- | Turn a websocket data source into an 'Event' data+ -- source+ makeEvents :: Pipe Payload Event DiscordM a+ makeEvents = forever $ do+ st@(DiscordState dState client ws _ _) <- get+ case dState of+ Create -> do+ Hello interval <- await+ sq <- liftIO . atomically $ newEmptyTMVar+ put st {getState=Start, getSequenceNum=sq}+ liftIO $ heartbeat interval ws sq+ Start -> do+ liftIO $ sendTextData ws+ (Identify (getAuth client) False 50 (0, 1))+ Dispatch o sq "READY" <- await+ liftIO . atomically $ putTMVar (getSequenceNum st) sq+ case parseEither parseJSON $ Object o of+ Right a -> yield $ Ready a+ Left reason -> liftIO $ errorM "Discord-hs.Gateway.Dispatch" reason+ put st {getState=Running}+ Running -> do+ pl <- await+ case pl of+ Dispatch _ sq _ -> do+ liftIO . atomically $ tryTakeTMVar (getSequenceNum st)+ >> putTMVar (getSequenceNum st) sq+ case parseDispatch pl of+ Left reason -> liftIO $ errorM "Discord-hs.Gateway.Dispatch" reason+ Right payload -> yield payload+ Heartbeat sq -> do+ liftIO . atomically $ tryTakeTMVar (getSequenceNum st)+ >> putTMVar (getSequenceNum st) sq+ liftIO . sendTextData ws $ Heartbeat sq+ Reconnect -> put st {getState=InvalidReconnect}+ InvalidSession -> put st {getState=Start}+ HeartbeatAck -> liftIO $ infoM "Discord-hs.Gateway.Heartbeat" "HeartbeatAck"+ _ -> do+ liftIO $ errorM "Discord-hs.Gateway.Error" "InvalidPacket"+ put st {getState=InvalidDead}+ InvalidReconnect -> put st {getState=InvalidDead}+ InvalidDead -> liftIO $ errorM "Discord-hs.Gateway.Error" "BotDied"+ + -- | Utility function providing core functionality by converting a Websocket+ -- 'Connection' to a stream of gateway 'Event's+ eventCore :: Connection -> Producer Event DiscordM ()+ eventCore conn = makeWebsocketSource conn >-> makeEvents
+ src/Network/Discord/Rest.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}+{-# OPTIONS_HADDOCK prune, not-home #-}+-- | Provides framework to interact with REST api gateways. Implementations specific to the+-- Discord API are provided in Network.Discord.Rest.Channel, Network.Discord.Rest.Guild,+-- and Network.Discord.Rest.User.+module Network.Discord.Rest+ ( module Network.Discord.Rest+ , module Network.Discord.Rest.Prelude+ , module Network.Discord.Rest.Channel+ , module Network.Discord.Rest.Guild+ , module Network.Discord.Rest.User+ ) where+ import Control.Monad (void)+ import Data.Maybe (fromJust)++ import Control.Lens+ import Control.Monad.Morph (lift)+ import Data.Aeson.Types+ import Data.Hashable+ import Network.URL+ import Network.Wreq+ import Pipes.Core++ import Network.Discord.Types as Dc+ import Network.Discord.Rest.Channel+ import Network.Discord.Rest.Guild+ import Network.Discord.Rest.Prelude+ import Network.Discord.Rest.User+ + -- | Perform an API request.+ fetch :: (DoFetch a, Hashable a)+ => a -> Pipes.Core.Proxy X () c' c DiscordM Fetched+ fetch req = restServer +>> (request $ Fetch req)+ + -- | Perform an API request, ignoring the response+ fetch' :: (DoFetch a, Hashable a)+ => a -> Pipes.Core.Proxy X () c' c DiscordM ()+ fetch' = void . fetch+ + -- | Alternative method of interacting with the REST api+ withApi :: Pipes.Core.Client Fetchable Fetched DiscordM Fetched+ -> Effect DiscordM ()+ withApi inner = void $ restServer +>> inner+ + -- | Provides a pipe to perform REST actions+ restServer :: Fetchable -> Server Fetchable Fetched DiscordM Fetched+ restServer req =+ lift (doFetch req) >>= respond >>= restServer++ -- | Obtains a new gateway to connect to.+ getGateway :: IO URL+ getGateway = do+ resp <- asValue =<< get (baseURL++"/gateway")+ return . fromJust $ importURL =<< parseMaybe getURL (resp ^. responseBody)+ where+ getURL :: Value -> Parser String+ getURL = withObject "url" (.: "url")
+ src/Network/Discord/Rest/Channel.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- | Provides actions for Channel API interactions+module Network.Discord.Rest.Channel+ (+ ChannelRequest(..)+ ) where+ import Control.Monad (when)++ import Control.Concurrent.STM+ import Control.Lens+ import Control.Monad.Morph (lift)+ import Data.Aeson+ import Data.ByteString.Lazy+ import Data.Hashable+ import Data.Monoid ((<>))+ import Data.Text+ import Data.Time.Clock.POSIX+ import Network.Wreq+ import qualified Control.Monad.State as ST (get, liftIO)++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types as Dc++ -- | Data constructor for Channel requests. See <https://discordapp.com/developers/docs/resources/Channel Channel API>+ data ChannelRequest a where+ -- | Gets a channel by its id.+ GetChannel :: Snowflake -> ChannelRequest Channel+ -- | Edits channels options.+ ModifyChannel :: ToJSON a => Snowflake -> a -> 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 -> [(Text, Text)] -> ChannelRequest [Message]+ -- | Gets a message in a channel by its id.+ GetChannelMessage :: Snowflake -> Snowflake -> ChannelRequest Message+ -- | Sends a message to a channel.+ CreateMessage :: Snowflake -> Text -> Maybe Embed -> ChannelRequest Message+ -- | Sends a message with a file to a channel.+ UploadFile :: Snowflake -> Text -> ByteString -> ChannelRequest Message+ -- | Edits a message content.+ EditMessage :: Message -> Text -> Maybe Embed -> ChannelRequest Message+ -- | Deletes a message.+ DeleteMessage :: Message -> ChannelRequest ()+ -- | Deletes a group of messages.+ BulkDeleteMessage :: Snowflake -> [Message] -> ChannelRequest ()+ -- | Edits a permission overrides for a channel.+ EditChannelPermissions :: ToJSON a => Snowflake -> Snowflake -> a -> ChannelRequest ()+ -- | Gets all instant invites to a channel.+ GetChannelInvites :: Snowflake -> ChannelRequest Object+ -- | Creates an instant invite to a channel.+ CreateChannelInvite :: ToJSON a => Snowflake -> a -> 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 ()++ instance Hashable (ChannelRequest a) where+ hashWithSalt s (GetChannel chan) = hashWithSalt s ("get_chan"::Text, chan)+ hashWithSalt s (ModifyChannel chan _) = hashWithSalt s ("mod_chan"::Text, chan)+ hashWithSalt s (DeleteChannel chan) = hashWithSalt s ("mod_chan"::Text, chan)+ hashWithSalt s (GetChannelMessages chan _) = hashWithSalt s ("msg"::Text, chan)+ hashWithSalt s (GetChannelMessage chan _) = hashWithSalt s ("get_msg"::Text, chan)+ hashWithSalt s (CreateMessage chan _ _) = hashWithSalt s ("msg"::Text, chan)+ hashWithSalt s (UploadFile chan _ _) = hashWithSalt s ("msg"::Text, chan)+ hashWithSalt s (EditMessage (Message _ chan _ _ _ _ _ _ _ _ _ _ _ _) _ _) =+ hashWithSalt s ("get_msg"::Text, chan)+ hashWithSalt s (DeleteMessage (Message _ chan _ _ _ _ _ _ _ _ _ _ _ _)) =+ hashWithSalt s ("get_msg"::Text, chan)+ hashWithSalt s (BulkDeleteMessage chan _) = hashWithSalt s ("del_msgs"::Text, chan)+ hashWithSalt s (EditChannelPermissions chan _ _) = hashWithSalt s ("perms"::Text, chan)+ hashWithSalt s (GetChannelInvites chan) = hashWithSalt s ("invites"::Text, chan)+ hashWithSalt s (CreateChannelInvite chan _) = hashWithSalt s ("invites"::Text, chan)+ hashWithSalt s (DeleteChannelPermission chan _) = hashWithSalt s ("perms"::Text, chan)+ hashWithSalt s (TriggerTypingIndicator chan) = hashWithSalt s ("tti"::Text, chan)+ hashWithSalt s (GetPinnedMessages chan) = hashWithSalt s ("pins"::Text, chan)+ hashWithSalt s (AddPinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)+ hashWithSalt s (DeletePinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)++ instance Eq (ChannelRequest a) where+ a == b = hash a == hash b++ instance RateLimit (ChannelRequest a) where+ getRateLimit req = do+ DiscordState {getRateLimits=rl} <- ST.get+ now <- ST.liftIO (fmap round getPOSIXTime :: IO Int)+ ST.liftIO . atomically $ do+ rateLimits <- readTVar rl+ case lookup (hash req) rateLimits of+ Nothing -> return Nothing+ Just a+ | a >= now -> return $ Just a+ | otherwise -> modifyTVar' rl (Dc.delete $ hash req) >> return Nothing++ setRateLimit req reset = do+ DiscordState {getRateLimits=rl} <- ST.get+ ST.liftIO . atomically . modifyTVar rl $ Dc.insert (hash req) reset++ instance (FromJSON a) => DoFetch (ChannelRequest a) where+ doFetch req = do+ waitRateLimit req+ SyncFetched <$> fetch req++ -- |Sends a request, used by doFetch.+ fetch :: FromJSON a => ChannelRequest a -> DiscordM a+ fetch request = do+ req <- baseRequest+ (resp, rlRem, rlNext) <- lift $ do+ resp <- case request of+ GetChannel chan -> getWith req+ (baseURL ++ "/channels/" ++ show chan)++ ModifyChannel chan patch -> customPayloadMethodWith "PATCH" req+ (baseURL ++ "/channels/" ++ show chan)+ (toJSON patch)++ DeleteChannel chan -> deleteWith req+ (baseURL ++ "/channels/" ++ show chan)++ GetChannelMessages chan patch -> getWith+ (Prelude.foldr (\(k, v) -> param k .~ [v]) req patch)+ (baseURL ++ "/channels/" ++ show chan ++ "/messages")++ GetChannelMessage chan msg -> getWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/messages/" ++ show msg)++ CreateMessage chan msg embed -> postWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/messages")+ (object $ [("content", toJSON msg)] <> maybeEmbed embed)++ UploadFile chan msg file -> postWith+ (req & header "Content-Type" .~ ["multipart/form-data"])+ (baseURL ++ "/channels/" ++ show chan ++ "/messages")+ ["content" := msg, "file" := file]++ EditMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) new embed ->+ customPayloadMethodWith "PATCH" req+ (baseURL ++ "/channels/" ++ show chan ++ "/messages/" ++ show msg)+ (object $ [("content", toJSON new)] <> maybeEmbed embed)++ DeleteMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) ->+ deleteWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/messages/" ++ show msg)++ BulkDeleteMessage chan msgs -> postWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/messages/bulk-delete")+ (object+ [("messages", toJSON+ $ Prelude.map (\(Message msg _ _ _ _ _ _ _ _ _ _ _ _ _) -> msg) msgs)])++ EditChannelPermissions chan perm patch -> putWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/permissions/" ++ show perm)+ (toJSON patch)++ GetChannelInvites chan -> getWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/invites")++ CreateChannelInvite chan patch -> postWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/invites")+ (toJSON patch)++ DeleteChannelPermission chan perm -> deleteWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/permissions/" ++ show perm)++ TriggerTypingIndicator chan -> postWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/typing")+ (toJSON ([]::[Int]))++ GetPinnedMessages chan -> getWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/pins")++ AddPinnedMessage chan msg -> putWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/pins/" ++ show msg)+ (toJSON ([]::[Int]))++ DeletePinnedMessage chan msg -> deleteWith req+ (baseURL ++ "/channels/" ++ show chan ++ "/pins/" ++ show msg)+ return (justRight . eitherDecode $ resp ^. responseBody+ , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Remaining"::Int+ , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Reset"::Int)+ when (rlRem == 0) $ setRateLimit request rlNext+ return resp+ where+ maybeEmbed :: Maybe Embed -> [(Text, Value)]+ maybeEmbed = maybe [] $ \embed -> [("embed", toJSON embed)]
+ src/Network/Discord/Rest/Guild.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- | Provides actions for Guild API interactions.+module Network.Discord.Rest.Guild+ (+ GuildRequest(..)+ ) where+ import Control.Monad (when)++ import Control.Concurrent.STM+ import Control.Lens+ import Control.Monad.Morph (lift)+ import Data.Aeson+ import Data.Hashable+ import Data.Text+ import Data.Time.Clock.POSIX+ import Network.Wreq+ import qualified Control.Monad.State as ST (get, liftIO)++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types as Dc+++ -- | Data constructor for Guild requests. See + -- <https://discordapp.com/developers/docs/resources/guild Guild API>+ data GuildRequest a where+ -- | 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'.+ ModifyGuild :: ToJSON a => Snowflake -> a -> 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'+ CreateGuildChannel :: ToJSON a => Snowflake -> a -> 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.+ ModifyChanPosition :: ToJSON a => Snowflake -> a -> GuildRequest [Channel]+ -- | Returns a guild 'Member' object for the specified user+ GetGuildMember :: Snowflake -> Snowflake -> GuildRequest Member+ -- | Returns a list of guild 'Member' objects that are members of the guild.+ ListGuildMembers :: Snowflake -> Range -> GuildRequest [Member]+ -- | 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 :: ToJSON a => Snowflake -> Snowflake -> a + -> GuildRequest Member+ -- | Modify attributes of a guild 'Member'. Fires a Guild Member Update 'Event'.+ ModifyGuildMember :: ToJSON a => Snowflake -> Snowflake -> a + -> 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.+ ModifyGuildRolePositions :: ToJSON a => Snowflake -> [a] -> 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 :: ToJSON a => Snowflake -> Snowflake -> a + -> 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'.+ CreateGuildIntegration :: ToJSON a => Snowflake -> a -> 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 :: ToJSON a => Snowflake -> Snowflake -> a -> 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++ instance Hashable (GuildRequest a) where+ hashWithSalt s (GetGuild g) = hashWithSalt s ("guild"::Text, g)+ hashWithSalt s (ModifyGuild g _) = hashWithSalt s ("guild"::Text, g)+ hashWithSalt s (DeleteGuild g) = hashWithSalt s ("guild"::Text, g)+ hashWithSalt s (GetGuildChannels g) = hashWithSalt s ("guild_chan"::Text, g)+ hashWithSalt s (CreateGuildChannel g _) = hashWithSalt s ("guild_chan"::Text, g)+ hashWithSalt s (ModifyChanPosition g _) = hashWithSalt s ("guild_chan"::Text, g)+ hashWithSalt s (GetGuildMember g _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (ListGuildMembers g _) = hashWithSalt s ("guild_membs"::Text, g)+ hashWithSalt s (AddGuildMember g _ _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (ModifyGuildMember g _ _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (RemoveGuildMember g _) = hashWithSalt s ("guild_memb"::Text, g)+ hashWithSalt s (GetGuildBans g) = hashWithSalt s ("guild_bans"::Text, g)+ hashWithSalt s (CreateGuildBan g _ _) = hashWithSalt s ("guild_ban" ::Text, g)+ hashWithSalt s (RemoveGuildBan g _) = hashWithSalt s ("guild_ban" ::Text, g)+ hashWithSalt s (GetGuildRoles g) = hashWithSalt s ("guild_roles"::Text, g)+ hashWithSalt s (CreateGuildRole g) = hashWithSalt s ("guild_roles"::Text, g)+ hashWithSalt s (ModifyGuildRolePositions g _)+ = hashWithSalt s ("guild_roles"::Text, g)+ hashWithSalt s (ModifyGuildRole g _ _) = hashWithSalt s ("guild_role" ::Text, g)+ hashWithSalt s (DeleteGuildRole g _ ) = hashWithSalt s ("guild_role" ::Text, g)+ hashWithSalt s (GetGuildPruneCount g _) = hashWithSalt s ("guild_prune"::Text, g)+ hashWithSalt s (BeginGuildPrune g _) = hashWithSalt s ("guild_prune"::Text, g)+ hashWithSalt s (GetGuildVoiceRegions g) = hashWithSalt s ("guild_voice"::Text, g)+ hashWithSalt s (GetGuildInvites g) = hashWithSalt s ("guild_invit"::Text, g)+ hashWithSalt s (GetGuildIntegrations g) = hashWithSalt s ("guild_integ"::Text, g)+ hashWithSalt s (CreateGuildIntegration g _)+ = hashWithSalt s ("guild_integ"::Text, g)+ hashWithSalt s (ModifyGuildIntegration g _ _)+ = hashWithSalt s ("guild_intgr"::Text, g)+ hashWithSalt s (DeleteGuildIntegration g _)+ = hashWithSalt s ("guild_intgr"::Text, g)+ hashWithSalt s (SyncGuildIntegration g _)= hashWithSalt s ("guild_sync" ::Text, g)+ hashWithSalt s (GetGuildEmbed g) = hashWithSalt s ("guild_embed"::Text, g)+ hashWithSalt s (ModifyGuildEmbed g _) = hashWithSalt s ("guild_embed"::Text, g)++ instance Eq (GuildRequest a) where+ a == b = hash a == hash b++ instance RateLimit (GuildRequest a) where+ getRateLimit req = do+ DiscordState {getRateLimits=rl} <- ST.get+ now <- ST.liftIO (fmap round getPOSIXTime :: IO Int)+ ST.liftIO . atomically $ do+ rateLimits <- readTVar rl+ case lookup (hash req) rateLimits of+ Nothing -> return Nothing+ Just a+ | a >= now -> return $ Just a+ | otherwise -> modifyTVar' rl (Dc.delete $ hash req) >> return Nothing++ setRateLimit req reset = do+ DiscordState {getRateLimits=rl} <- ST.get+ ST.liftIO . atomically . modifyTVar rl $ Dc.insert (hash req) reset+++ instance (FromJSON a) => DoFetch (GuildRequest a) where+ doFetch req = do+ waitRateLimit req+ SyncFetched <$> fetch req++ fetch :: FromJSON a => GuildRequest a -> DiscordM a+ fetch request = do+ req <- baseRequest+ (resp, rlRem, rlNext) <- lift $ do+ resp <- case request of+ GetGuild chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan)+ + ModifyGuild chan patch -> customPayloadMethodWith "PATCH" req+ (baseURL ++ "/guilds/" ++ show chan)+ (toJSON patch)++ DeleteGuild chan -> deleteWith req+ (baseURL ++ "/guilds/" ++ show chan)++ GetGuildChannels chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/channels")++ CreateGuildChannel chan patch -> postWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/channels")+ (toJSON patch)++ ModifyChanPosition chan patch -> customPayloadMethodWith "PATCH" req+ (baseURL ++ "/guilds/" ++ show chan ++ "/channels")+ (toJSON patch)++ GetGuildMember chan user -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/members/" ++ show user)++ ListGuildMembers chan range -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++"/members?" ++ toQueryString range)++ AddGuildMember chan user patch -> customPayloadMethodWith "PUT" req+ (baseURL ++ "/guilds/" ++ show chan ++ "/members/" ++ show user)+ (toJSON patch)++ ModifyGuildMember chan user patch -> customPayloadMethodWith "PATCH" req+ (baseURL ++ "/guilds/" ++ show chan ++ "/members/" ++ show user)+ (toJSON patch)++ RemoveGuildMember chan user -> deleteWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/members/"++ show user)++ GetGuildBans chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/bans")++ CreateGuildBan chan user msg -> customPayloadMethodWith "PUT" req+ (baseURL ++ "/guilds/" ++ show chan ++ "/bans/" ++ show user)+ ["delete-message-days" := msg]++ RemoveGuildBan chan user -> deleteWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/bans/" ++ show user)++ GetGuildRoles chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/roles")++ CreateGuildRole chan -> postWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/roles")+ (toJSON (""::Text))++ ModifyGuildRolePositions chan pos -> postWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/roles")+ (toJSON pos)++ ModifyGuildRole chan role patch -> postWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/roles/" ++ show role)+ (toJSON patch)++ DeleteGuildRole chan role -> deleteWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/roles/" ++ show role)++ GetGuildPruneCount chan days -> getWith req+ (baseURL++"/guilds/"++ show chan ++"/prune?days="++show days)++ BeginGuildPrune chan days -> postWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/prune?days=" ++ show days)+ (toJSON (""::Text))++ GetGuildVoiceRegions chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/regions")++ GetGuildInvites chan -> getWith req + (baseURL ++ "/guilds/" ++ show chan ++ "/invites")++ GetGuildIntegrations chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/integrations")++ CreateGuildIntegration chan patch -> postWith req+ (baseURL ++ "/guilds/"++ show chan ++ "/integrations")+ (toJSON patch)++ ModifyGuildIntegration chan integ patch -> customPayloadMethodWith "PATCH" req+ (baseURL ++ "/guilds/" ++ show chan ++ "/integrations/" ++ show integ)+ (toJSON patch)++ DeleteGuildIntegration chan integ -> deleteWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/integrations/" ++ show integ)++ SyncGuildIntegration chan integ -> postWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/integrations/" ++ show integ)+ (toJSON (""::Text))++ GetGuildEmbed chan -> getWith req+ (baseURL ++ "/guilds/" ++ show chan ++ "/embed")+ + ModifyGuildEmbed chan embed -> customPayloadMethodWith "PATCH" req+ (baseURL ++ "/guilds/" ++ show chan ++ "/embed")+ (toJSON embed)++ return (justRight . eitherDecode $ resp ^. responseBody+ , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Remaining"::Int+ , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Reset"::Int)+ when (rlRem == 0) $ setRateLimit request rlNext+ return resp
+ src/Network/Discord/Rest/Prelude.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}++-- | Utility and base types and functions for the Discord Rest API+module Network.Discord.Rest.Prelude where+ import Control.Concurrent (threadDelay)+ import Data.Version (showVersion)++ import Control.Lens+ import Data.Aeson+ import Data.ByteString.Char8 (pack)+ import Data.Default+ import Data.Hashable+ import Data.Time.Clock.POSIX+ import Network.Wreq+ import System.Log.Logger+ import qualified Control.Monad.State as St++ import Network.Discord.Types+ import Paths_discord_hs (version)++ -- | Read function specialized for Integers+ readInteger :: String -> Integer+ readInteger = read++ -- | The base url for API requests+ baseURL :: String+ baseURL = "https://discordapp.com/api/v6"++ -- | Construct base request with auth from Discord state+ baseRequest :: DiscordM Options+ baseRequest = do+ DiscordState {getClient=client} <- St.get+ return $ defaults+ & header "Authorization" .~ [pack . show $ getAuth client]+ & header "User-Agent" .~+ [pack $ "DiscordBot (https://github.com/jano017/Discord.hs,"+ ++ showVersion version+ ++ ")"]+ & header "Content-Type" .~ ["application/json"]++ -- | Class for rate-limitable actions+ class RateLimit a where+ -- | Return seconds to expiration if we're waiting+ -- for a rate limit to reset+ getRateLimit :: a -> DiscordM (Maybe Int)+ -- | Set seconds to the next rate limit reset when+ -- we hit a rate limit+ setRateLimit :: a -> Int -> DiscordM ()+ -- | If we hit a rate limit, wait for it to reset+ waitRateLimit :: a -> DiscordM ()+ waitRateLimit endpoint = do+ rl <- getRateLimit endpoint+ case rl of+ Nothing -> return ()+ Just a -> do+ now <- St.liftIO (fmap round getPOSIXTime :: IO Int)+ St.liftIO $ do+ infoM "Discord-hs.Rest" "Waiting for rate limit to reset..."+ threadDelay $ 1000000 * (a - now)+ putStrLn "Done"+ return ()+ + -- | Class over which performing a data retrieval action is defined+ class DoFetch a where+ doFetch :: a -> DiscordM Fetched++ -- | Polymorphic type for all DoFetch types+ data Fetchable = forall a. (DoFetch a, Hashable a) => Fetch a++ instance DoFetch Fetchable where+ doFetch (Fetch a) = doFetch a++ instance Hashable Fetchable where+ hashWithSalt s (Fetch a) = hashWithSalt s a++ instance Eq Fetchable where+ (Fetch a) == (Fetch b) = hash a == hash b++ -- | Result of a data retrieval action+ data Fetched = forall a. (FromJSON a) => SyncFetched a+ + -- | Represents a range of 'Snowflake's+ data Range = Range { after :: Snowflake, before :: Snowflake, limit :: Int}++ instance Default Range where+ def = Range 0 18446744073709551615 100+ + -- | Convert a Range to a query string+ toQueryString :: Range -> String+ toQueryString (Range a b l) = + "after=" ++ show a ++ "&before=" ++ show b ++ "&limit=" ++ show l
+ src/Network/Discord/Rest/User.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE GADTs, OverloadedStrings, InstanceSigs, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-- | Provide actions for User API interactions.+module Network.Discord.Rest.User+ (+ UserRequest(..)+ ) where+ import Control.Monad (when)++ import Control.Concurrent.STM+ import Control.Monad.Morph (lift)+ import Control.Lens+ import Data.Aeson+ import Data.Hashable+ import Data.Text+ import Data.Time.Clock.POSIX+ import Network.Wreq+ import qualified Control.Monad.State as ST (get, liftIO)++ import Network.Discord.Rest.Prelude+ import Network.Discord.Types as Dc++ -- | Data constructor for User requests. See+ -- <https://discordapp.com/developers/docs/resources/user User 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.+ ModifyCurrentUser :: ToJSON a => a -> UserRequest User+ -- | Returns a list of user 'Guild' objects the current user is a member of.+ -- Requires the guilds OAuth2 scope.+ GetCurrentUserGuilds :: Range -> UserRequest Guild+ -- | 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++ instance Hashable (UserRequest a) where+ hashWithSalt s (GetCurrentUser) = hashWithSalt s ("me"::Text)+ hashWithSalt s (GetUser _) = hashWithSalt s ("user"::Text)+ hashWithSalt s (ModifyCurrentUser _) = hashWithSalt s ("modify_user"::Text)+ hashWithSalt s (GetCurrentUserGuilds _) = hashWithSalt s ("get_user_guilds"::Text)+ hashWithSalt s (LeaveGuild g) = hashWithSalt s ("leaveGuild"::Text, g)+ hashWithSalt s (GetUserDMs) = hashWithSalt s ("get_dms"::Text)+ hashWithSalt s (CreateDM _) = hashWithSalt s ("make_dm"::Text)++ instance Eq (UserRequest a) where+ a == b = hash a == hash b++ instance RateLimit (UserRequest a) where+ getRateLimit req = do+ DiscordState {getRateLimits=rl} <- ST.get+ now <- ST.liftIO (fmap round getPOSIXTime :: IO Int)+ ST.liftIO . atomically $ do+ rateLimits <- readTVar rl+ case lookup (hash req) rateLimits of+ Nothing -> return Nothing+ Just a+ | a >= now -> return $ Just a+ | otherwise -> modifyTVar' rl (Dc.delete $ hash req) >> return Nothing++ setRateLimit req reset = do+ DiscordState {getRateLimits=rl} <- ST.get+ ST.liftIO . atomically . modifyTVar rl $ Dc.insert (hash req) reset++ instance (FromJSON a) => DoFetch (UserRequest a) where+ doFetch req = do+ waitRateLimit req+ SyncFetched <$> fetch req++ fetch :: FromJSON a => UserRequest a -> DiscordM a+ fetch request = do+ req <- baseRequest+ (resp, rlRem, rlNext) <- lift $ do+ resp <- case request of+ GetCurrentUser -> getWith req+ "/users/@me"+ GetUser user -> getWith req+ ("/users/" ++ show user)+ ModifyCurrentUser patch -> customPayloadMethodWith "PATCH" req+ "/users/@me"+ (toJSON patch)+ GetCurrentUserGuilds range -> getWith req+ ("/users/@me/guilds?" ++ toQueryString range)+ LeaveGuild guild -> deleteWith req+ ("/users/@me/guilds/" ++ show guild)+ GetUserDMs -> getWith req+ "/users/@me/channels"+ CreateDM (Snowflake user) -> postWith req+ "/users/@me/channels"+ ["recipient_id" := user]+ return (justRight . eitherDecode $ resp ^. responseBody+ , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Remaining"::Int+ , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Reset"::Int)+ when (rlRem == 0) $ setRateLimit request rlNext+ return resp
+ src/Network/Discord/Types.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE RankNTypes, ExistentialQuantification #-}+{-# OPTIONS_HADDOCK prune, not-home #-}+-- | Provides types and encoding/decoding code. Types should be identical to those provided+-- in the Discord API documentation.+module Network.Discord.Types+ ( module Network.Discord.Types+ , module Network.Discord.Types.Prelude+ , module Network.Discord.Types.Channel+ , module Network.Discord.Types.Events+ , module Network.Discord.Types.Gateway+ , module Network.Discord.Types.Guild+ ) where++ import Data.Proxy+ import Control.Monad.State (StateT)++ import Control.Concurrent.STM+ import Network.WebSockets (Connection)+ import System.IO.Unsafe (unsafePerformIO)++ import Network.Discord.Types.Channel+ import Network.Discord.Types.Events+ import Network.Discord.Types.Gateway+ import Network.Discord.Types.Guild+ import Network.Discord.Types.Prelude++ -- | Provides a list of possible states for the client gateway to be in.+ data StateEnum = Create | Start | Running | InvalidReconnect | InvalidDead++ -- | Stores details needed to manage the gateway and bot+ data DiscordState = forall a . (Client a) => DiscordState {+ getState :: StateEnum -- ^ Current state of the gateway+ , getClient :: a -- ^ Currently running bot client+ , getWebSocket :: Connection -- ^ Stored WebSocket gateway+ , getSequenceNum :: TMVar Integer -- ^ Heartbeat sequence number+ , getRateLimits :: TVar [(Int, Int)] -- ^ List of rate-limited endpoints+ }++ -- | Convenience type alias for the monad most used throughout most Discord.hs operations+ type DiscordM = StateT DiscordState IO+ + -- | The Client typeclass holds the majority of the user-customizable state,+ -- including merging states resulting from async operations.+ class Client c where+ -- | Provides authorization token associated with the client+ getAuth :: c -> Auth+ -- | Function for resolving state differences due to async operations.+ -- Developers are responsible for preventing race conditions.+ -- Remember as `merge newState oldState`+ merge :: c -- ^ Modified state+ -> c -- ^ Initial state+ -> c -- ^ Merged state+ merge _ st = st -- By default, we simply discard the modified state (we don't+ -- store state by default)++ -- | Control access to state. In cases where state locks aren't needed, this+ -- is most likely the best solution. This implementation most likely+ -- needs an accompanying {-\# NOINLINE getTMClient \#-} pragma to ensure+ -- that a single state is shared between events+ getTMClient :: TVar c+ getTMClient = unsafePerformIO $ newTVarIO undefined+ {-# NOINLINE getTMClient #-}++ -- | In some cases, state locks are needed to prevent race conditions or + -- TVars are an unwanted solution. In these cases, both getClient and+ -- modifyClient should be implemented.+ getSTMClient :: Proxy c -- ^ Type witness for the client+ -> STM c+ getSTMClient _ = readTVar getTMClient+ + -- | modifyClient is used by mergeClient to merge application states before+ -- and after an event handler is run+ {-# NOINLINE getSTMClient #-}+ modifyClient :: (c -> c) -> STM ()+ modifyClient f = modifyTVar getTMClient f+ + -- | Merges application states before and after an event handler+ mergeClient :: c -> STM ()+ mergeClient client = modifyClient $ merge client
+ src/Network/Discord/Types/Channel.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE OverloadedStrings, MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+-- | Data structures pertaining to Discord Channels+module Network.Discord.Types.Channel where+ import Control.Monad (mzero)+ import Data.Text as Text (pack, Text)++ import Data.Aeson+ import Data.Aeson.Types (Parser)+ import Data.Time.Clock+ import Data.Vector (toList)+ import qualified Data.HashMap.Strict as HM+ import qualified Data.Vector as V++ import Network.Discord.Types.Prelude++ -- |Represents information about a user.+ data User = User+ { userId :: {-# UNPACK #-} !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 (Object o) =+ User <$> o .: "id"+ <*> o .: "username"+ <*> o .: "discriminator"+ <*> o .:? "avatar"+ <*> o .:? "bot" .!= False+ <*> o .:? "mfa_enabled"+ <*> o .:? "verified"+ <*> o .:? "email"+ parseJSON _ = mzero++ -- | 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 :: 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 :: Snowflake+ } deriving (Show, Eq)++ instance FromJSON Channel where+ parseJSON = withObject "text or voice" $ \o -> do+ type' <- (o .: "type") :: Parser Int+ case type' of+ 0 ->+ Text <$> o .: "id"+ <*> o .: "guild_id"+ <*> o .: "name"+ <*> o .: "position"+ <*> o .: "permission_overwrites"+ <*> o .:? "topic" .!= ""+ <*> o .:? "last_message_id" .!= 0+ 1 ->+ DirectMessage <$> o .: "id"+ <*> o .: "recipients"+ <*> o .:? "last_message_id" .!= 0+ 2 ->+ Voice <$> o .: "id"+ <*> o .: "guild_id"+ <*> o .: "name"+ <*> o .: "position"+ <*> o .: "permission_overwrites"+ <*> o .: "bitrate"+ <*> o .: "user_limit"+ _ -> mzero++ -- | Permission overwrites for a channel.+ data Overwrite = Overwrite + { overwriteId:: {-# UNPACK #-} !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 (Object o) =+ Overwrite <$> o .: "id"+ <*> o .: "type"+ <*> o .: "allow"+ <*> o .: "deny"+ parseJSON _ = mzero++ -- | Represents information about a message in a Discord channel.+ data Message = Message+ { messageId :: {-# UNPACK #-} !Snowflake -- ^ The id of the message+ , messageChannel :: {-# UNPACK #-} !Snowflake -- ^ Id of the channel the message+ -- was sent in+ , messageAuthor :: User -- ^ The 'User' the message was sent+ -- by+ , messageContent :: Text -- ^ Contents of the message+ , messageTimestamp :: UTCTime -- ^ When the message was sent+ , messageEdited :: Maybe UTCTime -- ^ When/if the message was edited+ , messageTts :: Bool -- ^ Whether this message was a TTS+ -- message+ , messageEveryone :: Bool -- ^ Whether this message mentions+ -- everyone+ , messageMentions :: [User] -- ^ 'User's specifically mentioned in+ -- the message+ , messageMentionRoles :: [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 (Object 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+ parseJSON _ = mzero++ -- |Represents an attached to a message file.+ data Attachment = Attachment+ { attachmentId :: {-# UNPACK #-} !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 (Object o) =+ Attachment <$> o .: "id"+ <*> o .: "filename"+ <*> o .: "size"+ <*> o .: "url"+ <*> o .: "proxy_url"+ <*> o .:? "height"+ <*> o .:? "width"+ parseJSON _ = mzero++ -- |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 (Object 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+ | k == pack "footer" =+ (Footer <$> v .: "text"+ <*> v .:? "icon_url" .!= ""+ <*> v .:? "proxy_icon_url" .!= "") : a+ | k == pack "image" =+ (Image <$> v .: "url"+ <*> v .: "proxy_url"+ <*> v .: "height"+ <*> v .: "width") : a+ | k == pack "thumbnail" =+ (Thumbnail <$> v .: "url"+ <*> v .: "proxy_url"+ <*> v .: "height"+ <*> v .: "width") : a+ | k == pack "video" =+ (Video <$> v .: "url"+ <*> v .: "height"+ <*> v .: "width") : a+ | k == pack "provider" =+ (Provider <$> v .: "name"+ <*> v .:? "url" .!= "") : a+ | k == pack "author" =+ (Author <$> v .: "name"+ <*> v .:? "url" .!= ""+ <*> v .:? "icon_url" .!= ""+ <*> v .:? "proxy_icon_url" .!= "") : a+ to_embed k (Array v) a+ | k == pack "fields" =+ [Field <$> i .: "name"+ <*> i .: "value"+ <*> i .: "inline"+ | Object i <- toList v] ++ a+ to_embed _ _ a = a++ parseJSON _ = mzero++ instance ToJSON Embed where+ toJSON (Embed {..}) = object + [ "title" .= embedTitle+ , "type" .= embedType+ , "description" .= embedDesc+ , "url" .= embedUrl+ , "timestamp" .= embedTime+ , "color" .= embedColor+ ] |> makeSubEmbeds embedFields+ where+ (Object o) |> hm = Object $ HM.union o hm+ _ |> _ = error "Type mismatch"+ makeSubEmbeds = foldr embed HM.empty+ 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/Network/Discord/Types/Events.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings, GADTs #-}+-- | Data structures pertaining to gateway dispatch 'Event's+module Network.Discord.Types.Events where+ import Control.Monad (mzero)++ import Data.Aeson++ import Network.Discord.Types.Channel+ import Network.Discord.Types.Gateway+ import Network.Discord.Types.Guild (Member, Guild)+ import Network.Discord.Types.Prelude++ -- |Represents data sent on READY event.+ data Init = Init Int User [Channel] [Guild] String deriving Show++ -- |Allows Init type to be generated using a JSON response by Discord.+ instance FromJSON Init where+ parseJSON (Object o) = Init <$> o .: "v"+ <*> o .: "user"+ <*> o .: "private_channels"+ <*> o .: "guilds"+ <*> o .: "session_id"+ parseJSON _ = mzero++ -- |Represents possible events sent by discord. Detailed information can be found at https://discordapp.com/developers/docs/topics/gateway.+ data Event =+ Ready Init+ | Resumed Object+ | ChannelCreate Channel+ | ChannelUpdate Channel+ | ChannelDelete Channel+ | GuildCreate Guild+ | GuildUpdate Guild+ | GuildDelete Guild+ | GuildBanAdd Member+ | GuildBanRemove Member+ | GuildEmojiUpdate Object+ | GuildIntegrationsUpdate Object+ | GuildMemberAdd Member+ | GuildMemberRemove Member+ | GuildMemberUpdate Member+ | GuildMemberChunk Object+ | GuildRoleCreate Object+ | GuildRoleUpdate Object+ | GuildRoleDelete Object+ | MessageCreate Message+ | MessageUpdate Message+ | MessageDelete Object+ | MessageDeleteBulk Object+ | PresenceUpdate Object+ | TypingStart Object+ | UserSettingsUpdate Object+ | UserUpdate Object+ | VoiceStateUpdate Object+ | VoiceServerUpdate Object+ | UnknownEvent String Object+ deriving Show++ -- |Parses JSON stuff by Discord to an event type.+ parseDispatch :: Payload -> Either String Event+ parseDispatch (Dispatch ob _ ev) = case ev of+ "READY" -> Ready <$> reparse o+ "RESUMED" -> Resumed <$> reparse o+ "CHANNEL_CREATE" -> ChannelCreate <$> reparse o+ "CHANNEL_UPDATE" -> ChannelUpdate <$> reparse o+ "CHANNEL_DELETE" -> ChannelDelete <$> reparse o+ "GUILD_CREATE" -> GuildCreate <$> reparse o+ "GUILD_UPDATE" -> GuildUpdate <$> reparse o+ "GUILD_DELETE" -> GuildDelete <$> reparse o+ "GUILD_BAN_ADD" -> GuildBanAdd <$> reparse o+ "GUILD_BAN_REMOVE" -> GuildBanRemove <$> reparse o+ "GUILD_EMOJI_UPDATE" -> GuildEmojiUpdate <$> reparse o+ "GUILD_INTEGRATIONS_UPDATE" -> GuildIntegrationsUpdate <$> reparse o+ "GUILD_MEMBER_ADD" -> GuildMemberAdd <$> reparse o+ "GUILD_MEMBER_UPDATE" -> GuildMemberUpdate <$> reparse o+ "GUILD_MEMBER_REMOVE" -> GuildMemberRemove <$> reparse o+ "GUILD_MEMBER_CHUNK" -> GuildMemberChunk <$> reparse o+ "GUILD_ROLE_CREATE" -> GuildRoleCreate <$> reparse o+ "GUILD_ROLE_UPDATE" -> GuildRoleUpdate <$> reparse o+ "GUILD_ROLE_DELETE" -> GuildRoleDelete <$> reparse o+ "MESSAGE_CREATE" -> MessageCreate <$> reparse o+ "MESSAGE_UPDATE" -> MessageUpdate <$> reparse o+ "MESSAGE_DELETE" -> MessageDelete <$> reparse o+ "MESSAGE_DELETE_BULK" -> MessageDeleteBulk <$> reparse o+ "PRESENCE_UPDATE" -> PresenceUpdate <$> reparse o+ "TYPING_START" -> TypingStart <$> reparse o+ "USER_SETTINGS_UPDATE" -> UserSettingsUpdate <$> reparse o+ "VOICE_STATE_UPDATE" -> VoiceStateUpdate <$> reparse o+ "VOICE_SERVER_UPDATE" -> VoiceServerUpdate <$> reparse o+ _ -> UnknownEvent ev <$> reparse o+ where o = Object ob+ parseDispatch _ = error "Tried to parse non-Dispatch payload"
+ src/Network/Discord/Types/Gateway.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Data structures needed for interfacing with the Websocket+-- Gateway+module Network.Discord.Types.Gateway where+ import Control.Monad (mzero)+ import System.Info++ import Data.Aeson+ import Data.Aeson.Types+ import Network.WebSockets++ import Network.Discord.Types.Prelude++ -- |Represents all sorts of things that we can send to Discord.+ data Payload = Dispatch+ Object+ Integer+ String+ | Heartbeat+ Integer+ | Identify+ Auth+ Bool+ Integer+ (Int, Int)+ | StatusUpdate+ (Maybe Integer)+ (Maybe String)+ | VoiceStatusUpdate+ {-# UNPACK #-} !Snowflake+ !(Maybe Snowflake)+ Bool+ Bool+ | Resume+ String+ String+ Integer+ | Reconnect+ | RequestGuildMembers+ {-# UNPACK #-} !Snowflake+ String+ Integer+ | InvalidSession+ | Hello+ Int+ | HeartbeatAck+ | ParseError String+ deriving Show++ instance FromJSON Payload where+ parseJSON = withObject "payload" $ \o -> do+ op <- o .: "op" :: Parser Int+ case op of+ 0 -> Dispatch <$> o .: "d" <*> o .: "s" <*> o .: "t"+ 1 -> Heartbeat <$> o .: "d"+ 7 -> return Reconnect+ 9 -> return InvalidSession+ 10 -> (\od -> Hello <$> od .: "heartbeat_interval") =<< o .: "d"+ 11 -> return HeartbeatAck+ _ -> mzero++ instance ToJSON Payload where+ toJSON (Heartbeat i) = object [ "op" .= (1 :: Int), "d" .= i ]+ toJSON (Identify token compress large shard) = object [+ "op" .= (2 :: Int)+ , "d" .= object [+ "token" .= authToken token+ , "properties" .= object [+ "$os" .= os+ , "$browser" .= ("discord.hs" :: String)+ , "$device" .= ("discord.hs" :: String)+ , "$referrer" .= ("" :: String)+ , "$referring_domain" .= ("" :: String)+ ]+ , "compress" .= compress+ , "large_threshold" .= large+ , "shard" .= shard+ ]+ ]+ toJSON (StatusUpdate idle game) = object [+ "op" .= (3 :: Int)+ , "d" .= object [+ "idle_since" .= idle+ , "game" .= object [+ "name" .= game+ ]+ ]+ ]+ toJSON (VoiceStatusUpdate 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 guild query limit) = object [+ "op" .= (8 :: Int)+ , "d" .= object [+ "guild_id" .= guild+ , "query" .= query+ , "limit" .= limit+ ]+ ]+ toJSON _ = object []++ instance WebSocketsData Payload where+ fromLazyByteString bs = case eitherDecode bs of+ Right payload -> payload+ Left reason -> ParseError reason+ toLazyByteString = encode
+ src/Network/Discord/Types/Guild.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Types relating to Discord Guilds (servers)+module Network.Discord.Types.Guild where+ import Data.Time.Clock++ import Data.Aeson+ import Control.Applicative ((<|>))+ import Control.Monad (mzero)++ import Network.Discord.Types.Channel+ import Network.Discord.Types.Prelude++ -- |Representation of a guild member.+ data Member = GuildMember {-# UNPACK #-} !Snowflake User+ | MemberShort User (Maybe String) ![Snowflake]+ deriving Show+ instance FromJSON Member where+ parseJSON (Object o) =+ GuildMember <$> o .: "guild_id" <*> o .: "user"+ parseJSON _ = mzero++ -- | Guilds in Discord represent a collection of users and channels into an isolated+ -- "Server"+ data Guild+ = Guild + { guildId :: {-# UNPACK #-} !Snowflake -- ^ Gulid id+ , guildName :: String -- ^ Guild name (2 - 100 chars)+ , guildIcon :: String -- ^ Icon hash+ , guildSplash :: String -- ^ Splash hash+ , guildOwner :: !Snowflake -- ^ Guild owner id+ , guildRegion :: String -- ^ Guild voice region+ , guildAfkId :: !Snowflake -- ^ Id of afk channel+ , guildAfkTimeout :: !Integer -- ^ Afk timeout in seconds+ , guildEmbedEnabled :: !Bool -- ^ Is this guild embeddable?+ , guildEmbedChannel :: !Snowflake -- ^ Id of embedded channel+ , guildVerification :: !Integer -- ^ Level of verification+ , guildNotification :: !Integer -- ^ Level of default notifications+ , guildRoles :: [Role] -- ^ Array of 'Role' objects+ , guildEmojis :: [Emoji] -- ^ Array of 'Emoji' objects+ }+ | Unavailable + { guildId :: {-# UNPACK #-} !Snowflake+ } deriving Show++ instance FromJSON Guild where+ parseJSON (Object o) = do+ short <- o .:? "unavailable" .!= False+ if short+ then Unavailable <$> o .: "id"+ else+ Guild <$> o .: "id"+ <*> o .: "name"+ <*> o .:? "icon" .!= ""+ <*> o .:? "hash" .!= ""+ <*> o .: "owner_id"+ <*> o .: "region"+ <*> o .:? "afk_channel_id" .!= 0+ <*> o .:? "afk_timeout" .!= 0+ <*> o .:? "embed_enabled" .!= False+ <*> o .:? "embed_channel_id" .!= 0+ <*> o .: "verification_level"+ <*> o .: "default_message_notifications"+ <*> o .: "roles"+ <*> o .: "emojis"+ parseJSON _ = mzero++ -- | Represents an emoticon (emoji)+ data Emoji = Emoji+ { emojiId :: {-# UNPACK #-} !Snowflake -- ^ The emoji id+ , emojiName :: String -- ^ The emoji name+ , emojiRoles :: ![Snowflake] -- ^ Roles the emoji is active for+ , emojiManaged :: !Bool -- ^ Whether this emoji is managed+ } deriving (Show)++ instance FromJSON Emoji where+ parseJSON (Object o) =+ Emoji <$> o .: "id"+ <*> o .: "name"+ <*> o .: "roles"+ <*> o .: "managed"+ parseJSON _ = mzero++ -- | 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 :: {-# UNPACK #-} !Snowflake -- ^ The role id+ , roleName :: String -- ^ 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 (Object o) = Role+ <$> o .: "id"+ <*> o .: "name"+ <*> o .: "color"+ <*> o .: "hoist"+ <*> o .: "position"+ <*> o .: "permissions"+ <*> o .: "managed"+ <*> o .: "mentionable"+ parseJSON _ = mzero+ + -- | VoiceRegion is only refrenced in Guild endpoints, will be moved when voice support is added+ data VoiceRegion =+ VoiceRegion+ { regionId :: {-# UNPACK #-} !Snowflake -- ^ Unique id of the region+ , regionName :: String -- ^ Name of the region+ , regionHostname :: String -- ^ 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 (Object o) = VoiceRegion+ <$> o .: "id"+ <*> o .: "name"+ <*> o .: "sample_hostname"+ <*> o .: "sample_port"+ <*> o .: "vip"+ <*> o .: "optimal"+ <*> o .: "deprecated"+ <*> o .: "custom"+ parseJSON _ = mzero++ -- | Represents a code to add a user to a guild+ data Invite =+ Invite {+ inviteCode :: String -- ^ The invite code+ , inviteGuild :: !Snowflake -- ^ The guild the code will invite to+ , inviteChan :: !Snowflake -- ^ The channel the code will invite to+ }+ -- | Invite code with additional metadata+ | InviteLong Invite InviteMeta++ instance FromJSON Invite where+ parseJSON ob@(Object o) =+ InviteLong <$> parseJSON ob <*> parseJSON ob+ <|> Invite+ <$> o .: "code"+ <*> ((o .: "guild") >>= (.: "id"))+ <*> ((o .: "channel") >>= (.: "id"))+ parseJSON _ = mzero+ + -- | 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 (Object o) = InviteMeta+ <$> o .: "inviter"+ <*> o .: "uses"+ <*> o .: "max_uses"+ <*> o .: "max_age"+ <*> o .: "temporary"+ <*> o .: "created_at"+ <*> o .: "revoked"+ parseJSON _ = mzero++ -- | Represents the behavior of a third party account link.+ data Integration =+ Integration+ { integrationId :: {-# UNPACK #-} !Snowflake -- ^ Integration id+ , integrationName :: String -- ^ Integration name+ , integrationType :: String -- ^ 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 (Object 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"+ parseJSON _ = mzero+ + -- | Represents a third party account link.+ data IntegrationAccount =+ Account + { accountId :: String -- ^ The id of the account.+ , accountName :: String -- ^ The name of the account.+ } deriving (Show)++ instance FromJSON IntegrationAccount where+ parseJSON (Object o) = Account+ <$> o .: "id"+ <*> o .: "name"+ parseJSON _ = mzero++ -- | 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 :: {-# UNPACK #-} !Snowflake -- ^ The embed channel id+ }+ instance FromJSON GuildEmbed where+ parseJSON (Object o) = GuildEmbed+ <$> o .: "enabled"+ <*> o .: "snowflake"+ parseJSON _ = mzero++ instance ToJSON GuildEmbed where+ toJSON (GuildEmbed enabled snowflake) = object+ [ "enabled" .= enabled+ , "snowflake" .= snowflake+ ]
+ src/Network/Discord/Types/Prelude.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ExistentialQuantification, TypeSynonymInstances, GeneralizedNewtypeDeriving #-}+-- | Provides base types and utility functions needed for modules in Network.Discord.Types+module Network.Discord.Types.Prelude where+ import Data.Bits+ import Data.Word++ import Data.Aeson.Types+ import Data.Hashable+ import Data.Text+ import Data.Time.Clock+ import Data.Time.Clock.POSIX+ import Control.Monad (mzero)++ -- | Authorization token for the Discord API+ data Auth = Bot String+ | Client String+ | Bearer String+ + -- | Formats the token for use with the REST API+ instance Show Auth where+ show (Bot token) = "Bot " ++ token+ show (Client token) = token+ show (Bearer token) = "Bearer " ++ token++ -- | Get the raw token formatted for use with the websocket gateway+ authToken :: Auth -> String+ authToken (Bot token) = token+ authToken (Client token) = token+ authToken (Bearer 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, Hashable)++ instance Show Snowflake where+ show (Snowflake a) = show a++ instance ToJSON Snowflake where+ toJSON (Snowflake snowflake) = String . pack $ show snowflake++ instance FromJSON Snowflake where+ parseJSON (String snowflake) = Snowflake <$> (return . read $ 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++ -- | Delete a (key, value) pair if the key exists+ delete :: Eq a => a -> [(a, b)] -> [(a, b)]+ delete k ((x,y):xs)+ | k == x = delete k xs+ | otherwise = (x, y):delete k xs+ delete _ [] = []+ + -- | Insert or modify a (key, value) pair+ insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+ insert k v s = (k, v):delete k s++ -- | Return only the Right vaule from an either+ justRight :: (Show a) => Either a b -> b+ justRight (Right b) = b+ justRight (Left a) = error $ show a++ -- | Convert ToJSON values to FromJSON values+ reparse :: (ToJSON a, FromJSON b) => a -> Either String b+ reparse val = parseEither parseJSON $ toJSON val