diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/discord-hs.cabal b/discord-hs.cabal new file mode 100644 --- /dev/null +++ b/discord-hs.cabal @@ -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 API. + If for some reason hackage/stackage is failing to build + documentation, a backup set is hosted at +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 diff --git a/docs/Site.hs b/docs/Site.hs new file mode 100644 --- /dev/null +++ b/docs/Site.hs @@ -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 diff --git a/src/Network/Discord.hs b/src/Network/Discord.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord.hs @@ -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) diff --git a/src/Network/Discord/Framework.hs b/src/Network/Discord/Framework.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Framework.hs @@ -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 diff --git a/src/Network/Discord/Gateway.hs b/src/Network/Discord/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Gateway.hs @@ -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 diff --git a/src/Network/Discord/Rest.hs b/src/Network/Discord/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Rest.hs @@ -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") diff --git a/src/Network/Discord/Rest/Channel.hs b/src/Network/Discord/Rest/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Rest/Channel.hs @@ -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 + 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)] diff --git a/src/Network/Discord/Rest/Guild.hs b/src/Network/Discord/Rest/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Rest/Guild.hs @@ -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 + -- + 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 diff --git a/src/Network/Discord/Rest/Prelude.hs b/src/Network/Discord/Rest/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Rest/Prelude.hs @@ -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 diff --git a/src/Network/Discord/Rest/User.hs b/src/Network/Discord/Rest/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Rest/User.hs @@ -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 + -- + 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 diff --git a/src/Network/Discord/Types.hs b/src/Network/Discord/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types.hs @@ -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 diff --git a/src/Network/Discord/Types/Channel.hs b/src/Network/Discord/Types/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Channel.hs @@ -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) diff --git a/src/Network/Discord/Types/Events.hs b/src/Network/Discord/Types/Events.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Events.hs @@ -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" diff --git a/src/Network/Discord/Types/Gateway.hs b/src/Network/Discord/Types/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Gateway.hs @@ -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 diff --git a/src/Network/Discord/Types/Guild.hs b/src/Network/Discord/Types/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Guild.hs @@ -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 + ] diff --git a/src/Network/Discord/Types/Prelude.hs b/src/Network/Discord/Types/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Network/Discord/Types/Prelude.hs @@ -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